code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <fcntl.h>      /* for mingw */
#include <signal.h>
#include <stdio.h>
#include <errno.h>

#include "libguile/_scm.h"

#include "libguile/async.h"
#include "libguile/eval.h"
#include "libguile/root.h"
#include "libguile/vectors.h"

#include "libguile/validate.h"
#include "libguile/scmsigs.h"

#ifdef HAVE_IO_H
#include <io.h>  /* for mingw _pipe() */
#endif

#ifdef HAVE_PROCESS_H
#include <process.h>    /* for mingw */
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif

#ifdef __MINGW32__
#include <windows.h>
#define alarm(sec) (0)
/* This weird comma expression is because Sleep is void under Windows. */
#define sleep(sec) (Sleep ((sec) * 1000), 0)
#define usleep(usec) (Sleep ((usec) / 1000), 0)
#define pipe(fd) _pipe (fd, 256, O_BINARY)
#endif

/* SIGRETTYPE is the type that signal handlers return.  See <signal.h> */

#ifdef RETSIGTYPE
# define SIGRETTYPE RETSIGTYPE
#else
# ifdef STDC_HEADERS
#  define SIGRETTYPE void
# else
#  define SIGRETTYPE int
# endif
#endif

/* take_signal is installed as the C signal handler whenever a Scheme
   handler is set.  When a signal arrives, take_signal will write a
   byte into the 'signal pipe'.  The 'signal delivery thread' will
   read this pipe and queue the appropriate asyncs.

   When Guile is built without threads, the signal handler will
   install the async directly.
*/

/* Scheme vectors with information about a signal.  signal_handlers
   contains the handler procedure or #f, signal_handler_asyncs
   contains the thunk to be marked as an async when the signal arrives
   (or the cell with the thunk in a singlethreaded Guile), and
   signal_handler_threads points to the thread that a signal should be
   delivered to.
*/
static SCM *signal_handlers;
static SCM signal_handler_asyncs;
static SCM signal_handler_threads;

/* saves the original C handlers, when a new handler is installed.
   set to SIG_ERR if the original handler is installed.  */
#ifdef HAVE_SIGACTION
static struct sigaction orig_handlers[NSIG];
#else
static SIGRETTYPE (*orig_handlers[NSIG])(int);
#endif

static SCM
handler_to_async (SCM handler, int signum)
{
  if (scm_is_false (handler))
    return SCM_BOOL_F;
  else
    {
      SCM async = scm_primitive_eval_x (scm_list_3 (scm_sym_lambda, SCM_EOL,
						    scm_list_2 (handler,
								scm_from_int (signum))));
#if !SCM_USE_PTHREAD_THREADS
      async = scm_cons (async, SCM_BOOL_F);
#endif
      return async;
    }
}

#if SCM_USE_PTHREAD_THREADS
/* On mingw there's no notion of inter-process signals, only a raise()
   within the process itself which apparently invokes the registered handler
   immediately.  Not sure how well the following code will cope in this
   case.  It builds but it may not offer quite the same scheme-level
   semantics as on a proper system.  If you're relying on much in the way of
   signal handling on mingw you probably lose anyway.  */

static int signal_pipe[2];

static SIGRETTYPE
take_signal (int signum)
{
  size_t count;
  char sigbyte = signum;

  count = write (signal_pipe[1], &sigbyte, 1);

#ifndef HAVE_SIGACTION
  signal (signum, take_signal);
#endif
}

typedef struct {
  ssize_t res;
  int fd;
  char *buf;
  size_t n;
} read_without_guile_data;

static void *
do_read_without_guile (void *raw_data)
{
  read_without_guile_data *data = (read_without_guile_data *)raw_data;
  data->res = read (data->fd, data->buf, data->n);
  return NULL;
}

static ssize_t
read_without_guile (int fd, char *buf, size_t n)
{
  read_without_guile_data data;
  data.fd = fd;
  data.buf = buf;
  data.n = n;
  scm_without_guile (do_read_without_guile, &data);
  return data.res;
}

static SCM
signal_delivery_thread (void *data)
{
  int n, sig;
  char sigbyte;
#if HAVE_PTHREAD_SIGMASK  /* not on mingw, see notes above */
  sigset_t all_sigs;
  sigfillset (&all_sigs);
  scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
#endif

  while (1)
    {
      n = read_without_guile (signal_pipe[0], &sigbyte, 1);
      sig = sigbyte;
      if (n == 1 && sig >= 0 && sig < NSIG)
	{
	  SCM h, t;

	  h = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, sig);
	  t = SCM_SIMPLE_VECTOR_REF (signal_handler_threads, sig);
	  if (scm_is_true (h))
	    scm_system_async_mark_for_thread (h, t);
	}
      else if (n < 0 && errno != EINTR)
	perror ("error in signal delivery thread");
    }

  return SCM_UNSPECIFIED;	/* not reached */
}

static void
start_signal_delivery_thread (void)
{
  if (pipe (signal_pipe) != 0)
    scm_syserror (NULL);
  scm_spawn_thread (signal_delivery_thread, NULL,
		    scm_handle_by_message, "signal delivery thread");
}

static void
ensure_signal_delivery_thread ()
{
  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
  scm_i_pthread_once (&once, start_signal_delivery_thread);
}

#else /* !SCM_USE_PTHREAD_THREADS */

static SIGRETTYPE
take_signal (int signum)
{
  SCM cell = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, signum);
  scm_i_thread *t = SCM_I_CURRENT_THREAD;

  if (scm_is_false (SCM_CDR (cell)))
    {
      SCM_SETCDR (cell, t->active_asyncs);
      t->active_asyncs = cell;
      t->pending_asyncs = 1;
    }

#ifndef HAVE_SIGACTION
  signal (signum, take_signal);
#endif
}

static void
ensure_signal_delivery_thread ()
{
  return;
}

#endif /* !SCM_USE_PTHREAD_THREADS */

static void
install_handler (int signum, SCM thread, SCM handler, SCM async)
{
  SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, handler);
  SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, async);
  SCM_SIMPLE_VECTOR_SET (signal_handler_threads, signum, thread);
}

SCM
scm_sigaction (SCM signum, SCM handler, SCM flags)
{
  return scm_sigaction_for_thread (signum, handler, flags, SCM_UNDEFINED);
}

/* user interface for installation of signal handlers.  */
SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
           (SCM signum, SCM handler, SCM flags, SCM thread),
	    "Install or report the signal handler for a specified signal.\n\n"
	    "@var{signum} is the signal number, which can be specified using the value\n"
	    "of variables such as @code{SIGINT}.\n\n"
	    "If @var{handler} is omitted, @code{sigaction} returns a pair: the\n"
	    "CAR is the current\n"
	    "signal hander, which will be either an integer with the value @code{SIG_DFL}\n"
	    "(default action) or @code{SIG_IGN} (ignore), or the Scheme procedure which\n"
	    "handles the signal, or @code{#f} if a non-Scheme procedure handles the\n"
	    "signal.  The CDR contains the current @code{sigaction} flags for the handler.\n\n"
	    "If @var{handler} is provided, it is installed as the new handler for\n"
	    "@var{signum}.  @var{handler} can be a Scheme procedure taking one\n"
	    "argument, or the value of @code{SIG_DFL} (default action) or\n"
	    "@code{SIG_IGN} (ignore), or @code{#f} to restore whatever signal handler\n"
	    "was installed before @code{sigaction} was first used.  When\n"
	    "a scheme procedure has been specified, that procedure will run\n"
	    "in the given @var{thread}.   When no thread has been given, the\n"
	    "thread that made this call to @code{sigaction} is used.\n"
	    "Flags can optionally be specified for the new handler.\n"
	    "The return value is a pair with information about the\n"
	    "old handler as described above.\n\n"
	    "This interface does not provide access to the \"signal blocking\"\n"
	    "facility.  Maybe this is not needed, since the thread support may\n"
	    "provide solutions to the problem of consistent access to data\n"
	    "structures.")
#define FUNC_NAME s_scm_sigaction_for_thread
{
  int csig;
#ifdef HAVE_SIGACTION
  struct sigaction action;
  struct sigaction old_action;
#else
  SIGRETTYPE (* chandler) (int) = SIG_DFL;
  SIGRETTYPE (* old_chandler) (int);
#endif
  int query_only = 0;
  int save_handler = 0;

  SCM old_handler;
  SCM async;

  csig = scm_to_signed_integer (signum, 0, NSIG-1);

#if defined(HAVE_SIGACTION)
  action.sa_flags = 0;
  if (!SCM_UNBNDP (flags))
    action.sa_flags |= scm_to_int (flags);
  sigemptyset (&action.sa_mask);
#endif

  if (SCM_UNBNDP (thread))
    thread = scm_current_thread ();
  else
    {
      SCM_VALIDATE_THREAD (4, thread);
      if (scm_c_thread_exited_p (thread))
	SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
    }

  /* Allocate upfront, as we can't do it inside the critical
     section. */
  async = handler_to_async (handler, csig);

  ensure_signal_delivery_thread ();

  SCM_CRITICAL_SECTION_START;
  old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig);
  if (SCM_UNBNDP (handler))
    query_only = 1;
  else if (scm_is_integer (handler))
    {
      long handler_int = scm_to_long (handler);

      if (handler_int == (long) SIG_DFL || handler_int == (long) SIG_IGN)
	{
#ifdef HAVE_SIGACTION
	  action.sa_handler = (SIGRETTYPE (*) (int)) handler_int;
#else
	  chandler = (SIGRETTYPE (*) (int)) handler_int;
#endif
	  install_handler (csig, SCM_BOOL_F, SCM_BOOL_F, async);
	}
      else
	{
	  SCM_CRITICAL_SECTION_END;
	  SCM_OUT_OF_RANGE (2, handler);
	}
    }
  else if (scm_is_false (handler))
    {
      /* restore the default handler.  */
#ifdef HAVE_SIGACTION
      if (orig_handlers[csig].sa_handler == SIG_ERR)
	query_only = 1;
      else
	{
	  action = orig_handlers[csig];
	  orig_handlers[csig].sa_handler = SIG_ERR;
	  install_handler (csig, SCM_BOOL_F, SCM_BOOL_F, async);
	}
#else
      if (orig_handlers[csig] == SIG_ERR)
	query_only = 1;
      else
	{
	  chandler = orig_handlers[csig];
	  orig_handlers[csig] = SIG_ERR;
	  install_handler (csig, SCM_BOOL_F, SCM_BOOL_F, async);
	}
#endif
    }
  else
    {
      SCM_VALIDATE_PROC (2, handler);
#ifdef HAVE_SIGACTION
      action.sa_handler = take_signal;
      if (orig_handlers[csig].sa_handler == SIG_ERR)
	save_handler = 1;
#else
      chandler = take_signal;
      if (orig_handlers[csig] == SIG_ERR)
	save_handler = 1;
#endif
      install_handler (csig, thread, handler, async);
    }

  /* XXX - Silently ignore setting handlers for `program error signals'
     because they can't currently be handled by Scheme code.
  */

  switch (csig)
    {
      /* This list of program error signals is from the GNU Libc
         Reference Manual */
    case SIGFPE:
    case SIGILL:
    case SIGSEGV:
#ifdef SIGBUS
    case SIGBUS:
#endif
    case SIGABRT:
#if defined(SIGIOT) && (SIGIOT != SIGABRT)
    case SIGIOT:
#endif
#ifdef SIGTRAP
    case SIGTRAP:
#endif
#ifdef SIGEMT
    case SIGEMT:
#endif
#ifdef SIGSYS
    case SIGSYS:
#endif
      query_only = 1;
    }

#ifdef HAVE_SIGACTION
  if (query_only)
    {
      if (sigaction (csig, 0, &old_action) == -1)
	SCM_SYSERROR;
    }
  else
    {
      if (sigaction (csig, &action , &old_action) == -1)
	SCM_SYSERROR;
      if (save_handler)
	orig_handlers[csig] = old_action;
    }
  if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN)
    old_handler = scm_from_long ((long) old_action.sa_handler);
  SCM_CRITICAL_SECTION_END;
  return scm_cons (old_handler, scm_from_int (old_action.sa_flags));
#else
  if (query_only)
    {
      if ((old_chandler = signal (csig, SIG_IGN)) == SIG_ERR)
	SCM_SYSERROR;
      if (signal (csig, old_chandler) == SIG_ERR)
	SCM_SYSERROR;
    }
  else
    {
      if ((old_chandler = signal (csig, chandler)) == SIG_ERR)
	SCM_SYSERROR;
      if (save_handler)
	orig_handlers[csig] = old_chandler;
    }
  if (old_chandler == SIG_DFL || old_chandler == SIG_IGN)
    old_handler = scm_from_long ((long) old_chandler);
  SCM_CRITICAL_SECTION_END;
  return scm_cons (old_handler, scm_from_int (0));
#endif
}
#undef FUNC_NAME

SCM_DEFINE (scm_restore_signals, "restore-signals", 0, 0, 0,
            (void),
	    "Return all signal handlers to the values they had before any call to\n"
	    "@code{sigaction} was made.  The return value is unspecified.")
#define FUNC_NAME s_scm_restore_signals
{
  int i;
  for (i = 0; i < NSIG; i++)
    {
#ifdef HAVE_SIGACTION
      if (orig_handlers[i].sa_handler != SIG_ERR)
	{
	  if (sigaction (i, &orig_handlers[i], NULL) == -1)
	    SCM_SYSERROR;
	  orig_handlers[i].sa_handler = SIG_ERR;
	  SCM_SIMPLE_VECTOR_SET (*signal_handlers, i, SCM_BOOL_F);
	}
#else
      if (orig_handlers[i] != SIG_ERR)
	{
	  if (signal (i, orig_handlers[i]) == SIG_ERR)
	    SCM_SYSERROR;
	  orig_handlers[i] = SIG_ERR;
	  SCM_SIMPLE_VECTOR_SET (*signal_handlers, i, SCM_BOOL_F);
	}
#endif
    }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0,
           (SCM i),
	    "Set a timer to raise a @code{SIGALRM} signal after the specified\n"
	    "number of seconds (an integer).  It's advisable to install a signal\n"
	    "handler for\n"
	    "@code{SIGALRM} beforehand, since the default action is to terminate\n"
	    "the process.\n\n"
	    "The return value indicates the time remaining for the previous alarm,\n"
	    "if any.  The new value replaces the previous alarm.  If there was\n"
	    "no previous alarm, the return value is zero.")
#define FUNC_NAME s_scm_alarm
{
  return scm_from_uint (alarm (scm_to_uint (i)));
}
#undef FUNC_NAME

#ifdef HAVE_SETITIMER
SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0,
           (SCM which_timer,
            SCM interval_seconds, SCM interval_microseconds,
            SCM value_seconds, SCM value_microseconds),
            "Set the timer specified by @var{which_timer} according to the given\n"
            "@var{interval_seconds}, @var{interval_microseconds},\n"
            "@var{value_seconds}, and @var{value_microseconds} values.\n"
            "\n"
            "Return information about the timer's previous setting."
            "\n"
            "Errors are handled as described in the guile info pages under ``POSIX\n"
            "Interface Conventions''.\n"
            "\n"
            "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},\n"
            "and @code{ITIMER_PROF}.\n"
            "\n"
            "The return value will be a list of two cons pairs representing the\n"
            "current state of the given timer.  The first pair is the seconds and\n"
            "microseconds of the timer @code{it_interval}, and the second pair is\n"
            "the seconds and microseconds of the timer @code{it_value}.")
#define FUNC_NAME s_scm_setitimer
{
  int rv;
  int c_which_timer;
  struct itimerval new_timer;
  struct itimerval old_timer;

  c_which_timer = SCM_NUM2INT(1, which_timer);
  new_timer.it_interval.tv_sec = SCM_NUM2LONG(2, interval_seconds);
  new_timer.it_interval.tv_usec = SCM_NUM2LONG(3, interval_microseconds);
  new_timer.it_value.tv_sec = SCM_NUM2LONG(4, value_seconds);
  new_timer.it_value.tv_usec = SCM_NUM2LONG(5, value_microseconds);

  SCM_SYSCALL(rv = setitimer(c_which_timer, &new_timer, &old_timer));

  if(rv != 0)
    SCM_SYSERROR;

  return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
			       scm_from_long (old_timer.it_interval.tv_usec)),
		     scm_cons (scm_from_long (old_timer.it_value.tv_sec),
			       scm_from_long (old_timer.it_value.tv_usec)));
}
#undef FUNC_NAME
#endif /* HAVE_SETITIMER */

#ifdef HAVE_GETITIMER
SCM_DEFINE (scm_getitimer, "getitimer", 1, 0, 0,
  (SCM which_timer),
            "Return information about the timer specified by @var{which_timer}"
            "\n"
            "Errors are handled as described in the guile info pages under ``POSIX\n"
            "Interface Conventions''.\n"
            "\n"
            "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},\n"
            "and @code{ITIMER_PROF}.\n"
            "\n"
            "The return value will be a list of two cons pairs representing the\n"
            "current state of the given timer.  The first pair is the seconds and\n"
            "microseconds of the timer @code{it_interval}, and the second pair is\n"
            "the seconds and microseconds of the timer @code{it_value}.")
#define FUNC_NAME s_scm_getitimer
{
  int rv;
  int c_which_timer;
  struct itimerval old_timer;

  c_which_timer = SCM_NUM2INT(1, which_timer);

  SCM_SYSCALL(rv = getitimer(c_which_timer, &old_timer));

  if(rv != 0)
    SCM_SYSERROR;

  return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
			       scm_from_long (old_timer.it_interval.tv_usec)),
		     scm_cons (scm_from_long (old_timer.it_value.tv_sec),
			       scm_from_long (old_timer.it_value.tv_usec)));
}
#undef FUNC_NAME
#endif /* HAVE_GETITIMER */

#ifdef HAVE_PAUSE
SCM_DEFINE (scm_pause, "pause", 0, 0, 0,
           (),
	    "Pause the current process (thread?) until a signal arrives whose\n"
	    "action is to either terminate the current process or invoke a\n"
	    "handler procedure.  The return value is unspecified.")
#define FUNC_NAME s_scm_pause
{
  pause ();
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
           (SCM i),
	    "Wait for the given number of seconds (an integer) or until a signal\n"
	    "arrives.  The return value is zero if the time elapses or the number\n"
	    "of seconds remaining otherwise.\n"
	    "\n"
	    "See also @code{usleep}.")
#define FUNC_NAME s_scm_sleep
{
  return scm_from_uint (scm_std_sleep (scm_to_uint (i)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0,
           (SCM i),
	    "Wait the given period @var{usecs} microseconds (an integer).\n"
	    "If a signal arrives the wait stops and the return value is the\n"
	    "time remaining, in microseconds.  If the period elapses with no\n"
	    "signal the return is zero.\n"
	    "\n"
	    "On most systems the process scheduler is not microsecond accurate and\n"
	    "the actual period slept by @code{usleep} may be rounded to a system\n"
	    "clock tick boundary.  Traditionally such ticks were 10 milliseconds\n"
	    "apart, and that interval is often still used.\n"
	    "\n"
	    "See also @code{sleep}.")
#define FUNC_NAME s_scm_usleep
{
  return scm_from_ulong (scm_std_usleep (scm_to_ulong (i)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_raise, "raise", 1, 0, 0,
           (SCM sig),
	    "Sends a specified signal @var{sig} to the current process, where\n"
	    "@var{sig} is as described for the kill procedure.")
#define FUNC_NAME s_scm_raise
{
  if (raise (scm_to_int (sig)) != 0)
    SCM_SYSERROR;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_init_scmsigs ()
{
  int i;

  signal_handlers =
    SCM_VARIABLE_LOC (scm_c_define ("signal-handlers",
				  scm_c_make_vector (NSIG, SCM_BOOL_F)));
  signal_handler_asyncs =
    scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
  signal_handler_threads =
    scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));

  for (i = 0; i < NSIG; i++)
    {
#ifdef HAVE_SIGACTION
      orig_handlers[i].sa_handler = SIG_ERR;

#else
      orig_handlers[i] = SIG_ERR;
#endif
    }

  scm_c_define ("NSIG", scm_from_long (NSIG));
  scm_c_define ("SIG_IGN", scm_from_long ((long) SIG_IGN));
  scm_c_define ("SIG_DFL", scm_from_long ((long) SIG_DFL));
#ifdef SA_NOCLDSTOP
  scm_c_define ("SA_NOCLDSTOP", scm_from_long (SA_NOCLDSTOP));
#endif
#ifdef SA_RESTART
  scm_c_define ("SA_RESTART", scm_from_long (SA_RESTART));
#endif

#if defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER)
  /* Stuff needed by setitimer and getitimer. */
  scm_c_define ("ITIMER_REAL", scm_from_int (ITIMER_REAL));
  scm_c_define ("ITIMER_VIRTUAL", scm_from_int (ITIMER_VIRTUAL));
  scm_c_define ("ITIMER_PROF", scm_from_int (ITIMER_PROF));
#endif /* defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) */

#include "libguile/scmsigs.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_SCMSIGS_H
#define SCM_SCMSIGS_H

/* Copyright (C) 1995,1996,1997,1998,2000, 2002, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API SCM scm_sigaction (SCM signum, SCM handler, SCM flags);
SCM_API SCM scm_sigaction_for_thread (SCM signum, SCM handler, SCM flags,
				      SCM thread);
SCM_API SCM scm_restore_signals (void);
SCM_API SCM scm_alarm (SCM i);
SCM_API SCM scm_setitimer (SCM which_timer,
			   SCM interval_seconds, SCM interval_microseconds,
			   SCM value_seconds, SCM value_microseconds);
SCM_API SCM scm_getitimer (SCM which_timer);
SCM_API SCM scm_pause (void);
SCM_API SCM scm_sleep (SCM i);
SCM_API SCM scm_usleep (SCM i);
SCM_API SCM scm_raise (SCM sig);
SCM_API void scm_init_scmsigs (void);

#endif  /* SCM_SCMSIGS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/

license: unknown


code:
/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* "script.c" argv tricks for `#!' scripts.
   Authors: Aubrey Jaffer and Jim Blandy */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <stdio.h>
#include <errno.h>
#include <ctype.h>

#include "libguile/_scm.h"
#include "libguile/gh.h"
#include "libguile/load.h"
#include "libguile/version.h"

#include "libguile/validate.h"
#include "libguile/script.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>		/* for X_OK define */
#endif

#ifdef HAVE_IO_H
#include <io.h>
#endif

/* Concatentate str2 onto str1 at position n and return concatenated
   string if file exists; 0 otherwise. */

static char *
scm_cat_path (char *str1, const char *str2, long n)
{
  if (!n)
    n = strlen (str2);
  if (str1)
    {
      size_t len = strlen (str1);
      str1 = (char *) realloc (str1, (size_t) (len + n + 1));
      if (!str1)
	return 0L;
      strncat (str1 + len, str2, n);
      return str1;
    }
  str1 = (char *) scm_malloc ((size_t) (n + 1));
  if (!str1)
    return 0L;
  str1[0] = 0;
  strncat (str1, str2, n);
  return str1;
}

#if 0
static char *
scm_try_path (char *path)
{
  FILE *f;
  /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
  if (!path)
    return 0L;
  SCM_SYSCALL (f = fopen (path, "r");
    );
  if (f)
    {
      fclose (f);
      return path;
    }
  free (path);
  return 0L;
}

static char *
scm_sep_init_try (char *path, const char *sep, const char *initname)
{
  if (path)
    path = scm_cat_path (path, sep, 0L);
  if (path)
    path = scm_cat_path (path, initname, 0L);
  return scm_try_path (path);
}
#endif

#ifndef LINE_INCREMENTORS
#define LINE_INCREMENTORS  '\n'
#ifdef MSDOS
#define WHITE_SPACES  ' ':case '\t':case '\r':case '\f':case 26
#else
#define WHITE_SPACES  ' ':case '\t':case '\r':case '\f'
#endif /* def MSDOS */
#endif /* ndef LINE_INCREMENTORS */

#ifndef MAXPATHLEN
#define MAXPATHLEN 80
#endif /* ndef MAXPATHLEN */
#ifndef X_OK
#define X_OK 1
#endif /* ndef X_OK */

char *
scm_find_executable (const char *name)
{
  char tbuf[MAXPATHLEN];
  int i = 0, c;
  FILE *f;

  /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
  if (access (name, X_OK))
    return 0L;
  f = fopen (name, "r");
  if (!f)
    return 0L;
  if ((fgetc (f) == '#') && (fgetc (f) == '!'))
    {
      while (1)
	switch (c = fgetc (f))
	  {
	  case /*WHITE_SPACES */ ' ':
	  case '\t':
	  case '\r':
	  case '\f':
	  case EOF:
	    tbuf[i] = 0;
	    fclose (f);
	    return scm_cat_path (0L, tbuf, 0L);
	  default:
	    tbuf[i++] = c;
	    break;
	  }
    }
  fclose (f);
  return scm_cat_path (0L, name, 0L);
}

/* Read a \nnn-style escape.  We've just read the backslash.  */
static int
script_get_octal (FILE *f)
#define FUNC_NAME "script_get_octal"
{
  int i;
  int value = 0;

  for (i = 0; i < 3; i++)
    {
      int c = getc (f);
      if ('0' <= c && c <= '7')
	value = (value * 8) + (c - '0');
      else
	SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
			SCM_EOL);
    }
  return value;
}
#undef FUNC_NAME

static int
script_get_backslash (FILE *f)
#define FUNC_NAME "script_get_backslash"
{
  int c = getc (f);

  switch (c)
    {
    case 'a': return '\a';
    case 'b': return '\b';
    case 'f': return '\f';
    case 'n': return '\n';
    case 'r': return '\r';
    case 't': return '\t';
    case 'v': return '\v';

    case '\\':
    case ' ':
    case '\t':
    case '\n':
      return c;

    case '0': case '1': case '2': case '3':
    case '4': case '5': case '6': case '7':
      ungetc (c, f);
      return script_get_octal (f);

    case EOF:
      SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL);
      return 0; /* not reached? */

    default:
      SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL);
      return 0; /* not reached? */
    }
}
#undef FUNC_NAME

static char *
script_read_arg (FILE *f)
#define FUNC_NAME "script_read_arg"
{
  size_t size = 7;
  char *buf = scm_malloc (size + 1);
  size_t len = 0;

  if (! buf)
    return 0;

  for (;;)
    {
      int c = getc (f);
      switch (c)
	{
	case '\\':
	  c = script_get_backslash (f);
	  /* The above produces a new character to add to the argument.
             Fall through.  */
	default:
	  if (len >= size)
	    {
	      size = (size + 1) * 2;
	      buf = realloc (buf, size);
	      if (! buf)
		return 0;
	    }
	  buf[len++] = c;
	  break;

	case '\n':
	  /* This may terminate an arg now, but it will terminate the
             entire list next time through.  */
	  ungetc ('\n', f);
	case EOF:
	  if (len == 0)
	    {
	      free (buf);
	      return 0;
	    }
	  /* Otherwise, those characters terminate the argument; fall
             through.  */
	case ' ':
	  buf[len] = '\0';
	  return buf;

	case '\t':
	  free (buf);
	  SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL);
	  return 0; /* not reached? */
	}
    }
}
#undef FUNC_NAME

static int
script_meta_arg_P (char *arg)
{
  if ('\\' != arg[0])
    return 0L;
#ifdef MSDOS
  return !arg[1];
#else
  switch (arg[1])
    {
    case 0:
    case '%':
    case WHITE_SPACES:
      return !0;
    default:
      return 0L;
    }
#endif
}

char **
scm_get_meta_args (int argc, char **argv)
{
  int nargc = argc, argi = 1, nargi = 1;
  char *narg, **nargv;
  if (!(argc > 2 && script_meta_arg_P (argv[1])))
    return 0L;
  if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *))))
      return 0L;
  nargv[0] = argv[0];
  while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
    {
      FILE *f = fopen (argv[++argi], "r");
      if (f)
	{
	  nargc--;		/* to compensate for replacement of '\\' */
	  while (1)
	    switch (getc (f))
	      {
	      case EOF:
		return 0L;
	      default:
		continue;
	      case '\n':
		goto found_args;
	      }
	found_args:
	  while ((narg = script_read_arg (f)))
	    if (!(nargv = (char **) realloc (nargv,
					     (1 + ++nargc) * sizeof (char *))))
	        return 0L;
	    else
	      nargv[nargi++] = narg;
	  fclose (f);
	  nargv[nargi++] = argv[argi++];
	}
    }
  while (argi <= argc)
    nargv[nargi++] = argv[argi++];
  return nargv;
}

int
scm_count_argv (char **argv)
{
  int argc = 0;
  while (argv[argc])
    argc++;
  return argc;
}

/* For use in error messages.  */
char *scm_usage_name = 0;

void
scm_shell_usage (int fatal, char *message)
{
  FILE  *fp = (fatal ? stderr : stdout);

  if (message)
    fprintf (fp, "%s\n", message);

  fprintf (fp,
           "Usage: %s OPTION ...\n"
           "Evaluate Scheme code, interactively or from a script.\n"
           "\n"
           "  [-s] FILE      load Scheme source code from FILE, and exit\n"
           "  -c EXPR        evalute Scheme expression EXPR, and exit\n"
           "  --             stop scanning arguments; run interactively\n"
           "The above switches stop argument processing, and pass all\n"
           "remaining arguments as the value of (command-line).\n"
           "If FILE begins with `-' the -s switch is mandatory.\n"
           "\n"
           "  -L DIRECTORY   add DIRECTORY to the front of the module load path\n"
           "  -l FILE        load Scheme source code from FILE\n"
           "  -e FUNCTION    after reading script, apply FUNCTION to\n"
           "                 command line arguments\n"
           "  -ds            do -s script at this point\n"
           "  --debug        start with debugging evaluator and backtraces\n"
           "  --no-debug     start with normal evaluator\n"
           "                 Default is to enable debugging for interactive\n"
           "                 use, but not for `-s' and `-c'.\n"
	   "  -q             inhibit loading of user init file\n"
           "  --emacs        enable Emacs protocol (experimental)\n"
	   "  --use-srfi=LS  load SRFI modules for the SRFIs in LS,\n"
	   "                 which is a list of numbers like \"2,13,14\"\n"
           "  -h, --help     display this help and exit\n"
           "  -v, --version  display version information and exit\n"
	   "  \\              read arguments from following script lines\n"
           "\n"
	   "Please report bugs to bug-guile@gnu.org\n",
           scm_usage_name);

  if (fatal)
    exit (fatal);
}

/* Some symbols used by the command-line compiler.  */
SCM_SYMBOL (sym_load, "load");
SCM_SYMBOL (sym_eval_string, "eval-string");
SCM_SYMBOL (sym_command_line, "command-line");
SCM_SYMBOL (sym_begin, "begin");
SCM_SYMBOL (sym_turn_on_debugging, "turn-on-debugging");
SCM_SYMBOL (sym_load_user_init, "load-user-init");
SCM_SYMBOL (sym_top_repl, "top-repl");
SCM_SYMBOL (sym_quit, "quit");
SCM_SYMBOL (sym_use_srfis, "use-srfis");
SCM_SYMBOL (sym_load_path, "%load-path");
SCM_SYMBOL (sym_set_x, "set!");
SCM_SYMBOL (sym_cons, "cons");
SCM_SYMBOL (sym_at, "@");
SCM_SYMBOL (sym_atat, "@@");
SCM_SYMBOL (sym_main, "main");

/* Given an array of command-line switches, return a Scheme expression
   to carry out the actions specified by the switches.

   If you told me this should have been written in Scheme, I'd
   probably agree.  I'd say I didn't feel comfortable doing that in
   the present system.  You'd say, well, fix the system so you are
   comfortable doing that.  I'd agree again.  *shrug*
 */

static char guile[] = "guile";

static int
all_symbols (SCM list)
{
  while (scm_is_pair (list))
    {
      if (!scm_is_symbol (SCM_CAR (list)))
	return 0;
      list = SCM_CDR (list);
    }
  return 1;
}

SCM
scm_compile_shell_switches (int argc, char **argv)
{
  SCM tail = SCM_EOL;		/* We accumulate the list backwards,
				   and then reverse! it before we
				   return it.  */
  SCM do_script = SCM_EOL;	/* The element of the list containing
				   the "load" command, in case we get
				   the "-ds" switch.  */
  SCM entry_point = SCM_EOL;	/* for -e switch */
  SCM user_load_path = SCM_EOL; /* for -L switch */
  int interactive = 1;		/* Should we go interactive when done? */
  int inhibit_user_init = 0;	/* Don't load user init file */
  int use_emacs_interface = 0;
  int turn_on_debugging = 0;
  int dont_turn_on_debugging = 0;

  int i;
  char *argv0 = guile;

  if (argc > 0)
    {
      argv0 = argv[0];
      scm_usage_name = strrchr (argv[0], '/');
      if (! scm_usage_name)
	scm_usage_name = argv[0];
      else
	scm_usage_name++;
    }
  if (! scm_usage_name)
    scm_usage_name = guile;

  for (i = 1; i < argc; i++)
    {
      if ((! strcmp (argv[i], "-s")) || (argv[i][0] != '-')) /* load script */
	{
	  if ((argv[i][0] == '-') && (++i >= argc))
	    scm_shell_usage (1, "missing argument to `-s' switch");

	  /* If we specified the -ds option, do_script points to the
	     cdr of an expression like (load #f); we replace the car
	     (i.e., the #f) with the script name.  */
	  if (!scm_is_null (do_script))
	    {
	      SCM_SETCAR (do_script, scm_from_locale_string (argv[i]));
	      do_script = SCM_EOL;
	    }
	  else
	    /* Construct an application of LOAD to the script name.  */
	    tail = scm_cons (scm_cons2 (sym_load,
					scm_from_locale_string (argv[i]),
					SCM_EOL),
			       tail);
	  argv0 = argv[i];
	  i++;
	  interactive = 0;
	  break;
	}

      else if (! strcmp (argv[i], "-c")) /* evaluate expr */
	{
	  if (++i >= argc)
	    scm_shell_usage (1, "missing argument to `-c' switch");
	  tail = scm_cons (scm_cons2 (sym_eval_string,
				      scm_from_locale_string (argv[i]),
				      SCM_EOL),
			   tail);
	  i++;
	  interactive = 0;
	  break;
	}

      else if (! strcmp (argv[i], "--")) /* end args; go interactive */
	{
	  i++;
	  break;
	}

      else if (! strcmp (argv[i], "-l")) /* load a file */
	{
	  if (++i < argc)
	    tail = scm_cons (scm_cons2 (sym_load,
					scm_from_locale_string (argv[i]),
					SCM_EOL),
			     tail);
	  else
	    scm_shell_usage (1, "missing argument to `-l' switch");
	}

      else if (! strcmp (argv[i], "-L")) /* add to %load-path */
	{
	  if (++i < argc)
	    user_load_path =
	      scm_cons (scm_list_3 (sym_set_x,
				    sym_load_path,
				    scm_list_3 (sym_cons,
						scm_from_locale_string (argv[i]),
						sym_load_path)),
			user_load_path);
	  else
	    scm_shell_usage (1, "missing argument to `-L' switch");
	}

      else if (! strcmp (argv[i], "-e")) /* entry point */
	{
	  if (++i < argc)
	    {
	      SCM port
		= scm_open_input_string (scm_from_locale_string (argv[i]));
	      SCM arg1 = scm_read (port);
	      SCM arg2 = scm_read (port);

	      /* Recognize syntax of certain versions of Guile 1.4 and
		 transform to (@ MODULE-NAME FUNC).
	       */
	      if (scm_is_false (scm_eof_object_p (arg2)))
		entry_point = scm_list_3 (sym_at, arg1, arg2);
	      else if (scm_is_pair (arg1)
		       && !(scm_is_eq (SCM_CAR (arg1), sym_at)
			    || scm_is_eq (SCM_CAR (arg1), sym_atat))
		       && all_symbols (arg1))
		entry_point = scm_list_3 (sym_at, arg1, sym_main);
	      else
		entry_point = arg1;
	    }
	  else
	    scm_shell_usage (1, "missing argument to `-e' switch");
	}

      else if (! strcmp (argv[i], "-ds")) /* do script here */
	{
	  /* We put a dummy "load" expression, and let the -s put the
             filename in.  */
	  if (!scm_is_null (do_script))
	    scm_shell_usage (1, "the -ds switch may only be specified once");
	  do_script = scm_cons (SCM_BOOL_F, SCM_EOL);
	  tail = scm_cons (scm_cons (sym_load, do_script),
			   tail);
	}

      else if (! strcmp (argv[i], "--debug"))
	{
	  turn_on_debugging = 1;
	  dont_turn_on_debugging = 0;
	}

      else if (! strcmp (argv[i], "--no-debug"))
	{
	  dont_turn_on_debugging = 1;
	  turn_on_debugging = 0;
	}

      else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
	use_emacs_interface = 1;

      else if (! strcmp (argv[i], "-q")) /* don't load user init */
	inhibit_user_init = 1;

      else if (! strncmp (argv[i], "--use-srfi=", 11)) /* load SRFIs */
	{
	  SCM srfis = SCM_EOL;	/* List of requested SRFIs.  */
	  char * p = argv[i] + 11;
	  while (*p)
	    {
	      long num;
	      char * end;

	      num = strtol (p, &end, 10);
	      if (end - p > 0)
		{
		  srfis = scm_cons (scm_from_long (num), srfis);
		  if (*end)
		    {
		      if (*end == ',')
			p = end + 1;
		      else
			scm_shell_usage (1, "invalid SRFI specification");
		    }
		  else
		    break;
		}
	      else
		scm_shell_usage (1, "invalid SRFI specification");
	    }
	  if (scm_ilength (srfis) <= 0)
	    scm_shell_usage (1, "invalid SRFI specification");
	  srfis = scm_reverse_x (srfis, SCM_UNDEFINED);
	  tail = scm_cons (scm_list_2 (sym_use_srfis,
				       scm_list_2 (scm_sym_quote, srfis)),
			   tail);
	}

      else if (! strcmp (argv[i], "-h")
	       || ! strcmp (argv[i], "--help"))
	{
	  scm_shell_usage (0, 0);
	  exit (0);
	}

      else if (! strcmp (argv[i], "-v")
	       || ! strcmp (argv[i], "--version"))
	{
	  /* Print version number.  */
	  printf ("Guile %s\n"
		  "Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation\n"
		  "Guile may be distributed under the terms of the GNU General Public Licence;\n"
		  "certain other uses are permitted as well.  For details, see the file\n"
		  "`COPYING', which is included in the Guile distribution.\n"
		  "There is no warranty, to the extent permitted by law.\n",
		  scm_to_locale_string (scm_version ()));
	  exit (0);
	}

      else
	{
	  fprintf (stderr, "%s: Unrecognized switch `%s'\n",
		   scm_usage_name, argv[i]);
	  scm_shell_usage (1, 0);
	}
    }

  /* Check to make sure the -ds got a -s. */
  if (!scm_is_null (do_script))
    scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");

  /* Make any remaining arguments available to the
     script/command/whatever.  */
  scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0);

  /* If the --emacs switch was set, now is when we process it.  */
  scm_c_define ("use-emacs-interface", scm_from_bool (use_emacs_interface));

  /* Handle the `-e' switch, if it was specified.  */
  if (!scm_is_null (entry_point))
    tail = scm_cons (scm_cons2 (entry_point,
				scm_cons (sym_command_line, SCM_EOL),
				SCM_EOL),
		       tail);

  /* If we didn't end with a -c or a -s, start the repl.  */
  if (interactive)
    {
      tail = scm_cons (scm_cons (sym_top_repl, SCM_EOL), tail);
    }
  else
    {
      /* After doing all the other actions prescribed by the command line,
	 quit.  */
      tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
		       tail);
    }

  /* After the following line, actions will be added to the front. */
  tail = scm_reverse_x (tail, SCM_UNDEFINED);

  /* add the user-specified load path here, so it won't be in effect
     during the loading of the user's customization file. */
  if(!scm_is_null(user_load_path))
    {
      tail = scm_append_x( scm_cons2(user_load_path, tail, SCM_EOL) );
    }

  /* If we didn't end with a -c or a -s and didn't supply a -q, load
     the user's customization file.  */
  if (interactive && !inhibit_user_init)
    {
      tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
    }

  /* If debugging was requested, or we are interactive and debugging
     was not explicitly turned off, turn on debugging. */
  if (turn_on_debugging || (interactive && !dont_turn_on_debugging))
    {
      tail = scm_cons (scm_cons (sym_turn_on_debugging, SCM_EOL), tail);
    }

  {
    SCM val = scm_cons (sym_begin, tail);

#if 0
    scm_write (val, SCM_UNDEFINED);
    scm_newline (SCM_UNDEFINED);
#endif

    return val;
  }
}

void
scm_shell (int argc, char **argv)
{
  /* If present, add SCSH-style meta-arguments from the top of the
     script file to the argument vector.  See the SCSH manual: "The
     meta argument" for more details.  */
  {
    char **new_argv = scm_get_meta_args (argc, argv);

    if (new_argv)
      {
	argv = new_argv;
	argc = scm_count_argv (new_argv);
      }
  }

  exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv),
				     scm_current_module ())));
}

void
scm_init_script ()
{
#include "libguile/script.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_SCRIPT_H
#define SCM_SCRIPT_H

/* Copyright (C) 1997,1998,2000, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API char *scm_find_executable (const char *name);
SCM_API char *scm_find_impl_file (char *exec_path,
				  const char *generic_name,
				  const char *initname,
				  const char *sep);
SCM_API char **scm_get_meta_args (int argc, char **argv);
SCM_API int scm_count_argv (char **argv);
SCM_API void scm_shell_usage (int fatal, char *message);
SCM_API SCM scm_compile_shell_switches (int argc, char **argv);
SCM_API void scm_shell (int argc, char **argv);
SCM_API char *scm_usage_name;
SCM_API void scm_init_script (void);

#endif  /* SCM_SCRIPT_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004 Free Software
 * Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <errno.h>
#include <signal.h>  /* for SIG constants */
#include <stdlib.h>  /* for getenv */

#include "libguile/_scm.h"

#include "libguile/scmsigs.h"
#include "libguile/strings.h"

#include "libguile/validate.h"
#include "libguile/simpos.h"
#include "libguile/dynwind.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#if HAVE_SYS_WAIT_H
# include <sys/wait.h>
#endif

#include "posix.h"

extern int system();

#ifdef HAVE_SYSTEM
SCM_DEFINE (scm_system, "system", 0, 1, 0,
           (SCM cmd),
	    "Execute @var{cmd} using the operating system's \"command\n"
	    "processor\".  Under Unix this is usually the default shell\n"
	    "@code{sh}.  The value returned is @var{cmd}'s exit status as\n"
	    "returned by @code{waitpid}, which can be interpreted using\n"
	    "@code{status:exit-val} and friends.\n"
	    "\n"
	    "If @code{system} is called without arguments, return a boolean\n"
	    "indicating whether the command processor is available.")
#define FUNC_NAME s_scm_system
{
  int rv, eno;
  char *c_cmd;

  if (SCM_UNBNDP (cmd))
    {
      rv = system (NULL);
      return scm_from_bool(rv);
    }
  SCM_VALIDATE_STRING (1, cmd);
  errno = 0;
  c_cmd = scm_to_locale_string (cmd);
  rv = system (c_cmd);
  eno = errno; free (c_cmd); errno = eno;
  if (rv == -1 || (rv == 127 && errno != 0))
    SCM_SYSERROR;
  return scm_from_int (rv);
}
#undef FUNC_NAME
#endif /* HAVE_SYSTEM */

#ifdef HAVE_SYSTEM
#ifdef HAVE_WAITPID

static void
free_string_pointers (void *data)
{
  scm_i_free_string_pointers ((char **)data);
}

SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
           (SCM args),
"Execute the command indicated by @var{args}.  The first element must\n"
"be a string indicating the command to be executed, and the remaining\n"
"items must be strings representing each of the arguments to that\n"
"command.\n"
"\n"
"This function returns the exit status of the command as provided by\n"
"@code{waitpid}.  This value can be handled with @code{status:exit-val}\n"
"and the related functions.\n"
"\n"
"@code{system*} is similar to @code{system}, but accepts only one\n"
"string per-argument, and performs no shell interpretation.  The\n"
"command is executed using fork and execlp.  Accordingly this function\n"
"may be safer than @code{system} in situations where shell\n"
"interpretation is not required.\n"
"\n"
"Example: (system* \"echo\" \"foo\" \"bar\")")
#define FUNC_NAME s_scm_system_star
{
  if (scm_is_null (args))
    SCM_WRONG_NUM_ARGS ();

  if (scm_is_pair (args))
    {
      SCM oldint;
      SCM oldquit;
      SCM sig_ign;
      SCM sigint;
      SCM sigquit;
      int pid;
      char **execargv;

      scm_dynwind_begin (0);

      /* allocate before fork */
      execargv = scm_i_allocate_string_pointers (args);
      scm_dynwind_unwind_handler (free_string_pointers, execargv,
				  SCM_F_WIND_EXPLICITLY);

      /* make sure the child can't kill us (as per normal system call) */
      sig_ign = scm_from_long ((unsigned long) SIG_IGN);
      sigint = scm_from_int (SIGINT);
      sigquit = scm_from_int (SIGQUIT);
      oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED);
      oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED);

      pid = fork ();
      if (pid == 0)
        {
          /* child */
          execvp (execargv[0], execargv);
          SCM_SYSERROR;
          /* not reached.  */
	  scm_dynwind_end ();
          return SCM_BOOL_F;
        }
      else
        {
          /* parent */
          int wait_result, status;

          if (pid == -1)
            SCM_SYSERROR;

          SCM_SYSCALL (wait_result = waitpid (pid, &status, 0));
          if (wait_result == -1)
	    SCM_SYSERROR;
          scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint));
          scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit));

	  scm_dynwind_end ();
          return scm_from_int (status);
        }
    }
  else
    SCM_WRONG_TYPE_ARG (1, args);
}
#undef FUNC_NAME
#endif /* HAVE_WAITPID */
#endif /* HAVE_SYSTEM */

SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0,
            (SCM nam),
	    "Looks up the string @var{name} in the current environment.  The return\n"
	    "value is @code{#f} unless a string of the form @code{NAME=VALUE} is\n"
	    "found, in which case the string @code{VALUE} is returned.")
#define FUNC_NAME s_scm_getenv
{
  char *val;
  char *var = scm_to_locale_string (nam);
  val = getenv (var);
  free (var);
  return val ? scm_from_locale_string (val) : SCM_BOOL_F;
}
#undef FUNC_NAME

/* simple exit, without unwinding the scheme stack or flushing ports.  */
SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0,
            (SCM status),
	    "Terminate the current process without unwinding the Scheme\n"
	    "stack.  The exit status is @var{status} if supplied, otherwise\n"
	    "zero.")
#define FUNC_NAME s_scm_primitive_exit
{
  int cstatus = 0;
  if (!SCM_UNBNDP (status))
    cstatus = scm_to_int (status);
  exit (cstatus);
}
#undef FUNC_NAME

SCM_DEFINE (scm_primitive__exit, "primitive-_exit", 0, 1, 0,
            (SCM status),
	    "Terminate the current process using the _exit() system call and\n"
	    "without unwinding the Scheme stack.  The exit status is\n"
	    "@var{status} if supplied, otherwise zero.\n"
	    "\n"
	    "This function is typically useful after a fork, to ensure no\n"
	    "Scheme cleanups or @code{atexit} handlers are run (those\n"
	    "usually belonging in the parent rather than the child).")
#define FUNC_NAME s_scm_primitive__exit
{
  int cstatus = 0;
  if (!SCM_UNBNDP (status))
    cstatus = scm_to_int (status);
  _exit (cstatus);
}
#undef FUNC_NAME

void
scm_init_simpos ()
{
#include "libguile/simpos.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_SIMPOS_H
#define SCM_SIMPOS_H

/* Copyright (C) 1995,1996,1997,1998,2000, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API SCM scm_system (SCM cmd);
SCM_API SCM scm_system_star (SCM cmds);
SCM_API SCM scm_getenv (SCM nam);
SCM_API SCM scm_primitive_exit (SCM status);
SCM_API SCM scm_primitive__exit (SCM status);
SCM_API void scm_init_simpos (void);

#endif  /* SCM_SIMPOS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <stdio.h>
#include <errno.h>

#include "libguile/_scm.h"

#include "libguile/async.h"
#include "libguile/objects.h"
#include "libguile/goops.h"
#include "libguile/ports.h"

#ifdef HAVE_MALLOC_H
#include <malloc.h>
#endif

#include "libguile/smob.h"

/* scm_smobs scm_numsmob
 * implement a fixed sized array of smob records.
 * Indexes into this table are used when generating type
 * tags for smobjects (if you know a tag you can get an index and conversely).
 */

#define MAX_SMOB_COUNT 256
long scm_numsmob;
scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];

/* Lower 16 bit of data must be zero.
*/
void
scm_i_set_smob_flags (SCM x, scm_t_bits data)
{
  SCM_SET_CELL_WORD_0 (x, (SCM_CELL_WORD_0 (x) & 0xFFFF) | data);
}

void
scm_assert_smob_type (scm_t_bits tag, SCM val)
{
  if (!SCM_SMOB_PREDICATE (tag, val))
    scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
}

/* {Mark}
 */

/* This function is vestigial.  It used to be the mark function's
   responsibility to set the mark bit on the smob or port, but now the
   generic marking routine in gc.c takes care of that, and a zero
   pointer for a mark function means "don't bother".  So you never
   need scm_mark0.

   However, we leave it here because it's harmless to call it, and
   people out there have smob code that uses it, and there's no reason
   to make their links fail.  */

SCM
scm_mark0 (SCM ptr SCM_UNUSED)
{
  return SCM_BOOL_F;
}

SCM
/* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
   be used for real pairs. */
scm_markcdr (SCM ptr)
{
  return SCM_CELL_OBJECT_1 (ptr);
}

/* {Free}
 */

size_t
scm_free0 (SCM ptr SCM_UNUSED)
{
  return 0;
}

size_t
scm_smob_free (SCM obj)
{
  long n = SCM_SMOBNUM (obj);
  if (scm_smobs[n].size > 0)
    scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
		 scm_smobs[n].size, SCM_SMOBNAME (n));
  return 0;
}

/* {Print}
 */

int
scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  long n = SCM_SMOBNUM (exp);
  scm_puts ("#<", port);
  scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
  scm_putc (' ', port);
  if (scm_smobs[n].size)
    scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
  else
    scm_uintprint (SCM_UNPACK (exp), 16, port);
  scm_putc ('>', port);
  return 1;
}

/* {Apply}
 */

#define SCM_SMOB_APPLY0(SMOB) \
  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
#define SCM_SMOB_APPLY1(SMOB, A1) \
  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
#define SCM_SMOB_APPLY2(SMOB, A1, A2) \
  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
#define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)

static SCM
scm_smob_apply_0_010 (SCM smob)
{
  return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_0_020 (SCM smob)
{
  return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_0_030 (SCM smob)
{
  return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_0_001 (SCM smob)
{
  return SCM_SMOB_APPLY1 (smob, SCM_EOL);
}

static SCM
scm_smob_apply_0_011 (SCM smob)
{
  return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL);
}

static SCM
scm_smob_apply_0_021 (SCM smob)
{
  return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL);
}

static SCM
scm_smob_apply_0_error (SCM smob)
{
  scm_wrong_num_args (smob);
}

static SCM
scm_smob_apply_1_020 (SCM smob, SCM a1)
{
  return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_1_030 (SCM smob, SCM a1)
{
  return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_1_001 (SCM smob, SCM a1)
{
  return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1));
}

static SCM
scm_smob_apply_1_011 (SCM smob, SCM a1)
{
  return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL);
}

static SCM
scm_smob_apply_1_021 (SCM smob, SCM a1)
{
  return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL);
}

static SCM
scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED)
{
  scm_wrong_num_args (smob);
}

static SCM
scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2)
{
  return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2)
{
  return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2));
}

static SCM
scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2)
{
  return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2));
}

static SCM
scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2)
{
  return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL);
}

static SCM
scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED)
{
  scm_wrong_num_args (smob);
}

static SCM
scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst)
{
  if (!scm_is_null (SCM_CDR (rst)))
    scm_wrong_num_args (smob);
  return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst));
}

static SCM
scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst)
{
  return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst));
}

static SCM
scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst)
{
  return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst));
}

static SCM
scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
{
  return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
}

static SCM
scm_smob_apply_3_error (SCM smob,
			SCM a1 SCM_UNUSED,
			SCM a2 SCM_UNUSED,
			SCM rst SCM_UNUSED)
{
  scm_wrong_num_args (smob);
}

scm_t_bits
scm_make_smob_type (char const *name, size_t size)
#define FUNC_NAME "scm_make_smob_type"
{
  long new_smob;

  SCM_CRITICAL_SECTION_START;
  new_smob = scm_numsmob;
  if (scm_numsmob != MAX_SMOB_COUNT)
    ++scm_numsmob;
  SCM_CRITICAL_SECTION_END;

  if (new_smob == MAX_SMOB_COUNT)
    scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);

  scm_smobs[new_smob].name = name;
  if (size != 0)
    {
      scm_smobs[new_smob].size = size;
      scm_smobs[new_smob].free = scm_smob_free;
    }

  /* Make a class object if Goops is present. */
  if (scm_smob_class)
    scm_smob_class[new_smob] = scm_make_extended_class (name, 0);

  return scm_tc7_smob + new_smob * 256;
}
#undef FUNC_NAME

void
scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
{
  scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
}

void
scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
{
  scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
}

void
scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*))
{
  scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
}

void
scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
{
  scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
}

void
scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
		    unsigned int req, unsigned int opt, unsigned int rst)
{
  SCM (*apply_0) (SCM);
  SCM (*apply_1) (SCM, SCM);
  SCM (*apply_2) (SCM, SCM, SCM);
  SCM (*apply_3) (SCM, SCM, SCM, SCM);
  int type = SCM_GSUBR_MAKTYPE (req, opt, rst);

  if (rst > 1 || req + opt + rst > 3)
    {
      puts ("Unsupported smob application type");
      abort ();
    }

  switch (type)
    {
    case SCM_GSUBR_MAKTYPE (0, 0, 0):
      apply_0 = apply; break;
    case SCM_GSUBR_MAKTYPE (0, 1, 0):
      apply_0 = scm_smob_apply_0_010; break;
    case SCM_GSUBR_MAKTYPE (0, 2, 0):
      apply_0 = scm_smob_apply_0_020; break;
    case SCM_GSUBR_MAKTYPE (0, 3, 0):
      apply_0 = scm_smob_apply_0_030; break;
    case SCM_GSUBR_MAKTYPE (0, 0, 1):
      apply_0 = scm_smob_apply_0_001; break;
    case SCM_GSUBR_MAKTYPE (0, 1, 1):
      apply_0 = scm_smob_apply_0_011; break;
    case SCM_GSUBR_MAKTYPE (0, 2, 1):
      apply_0 = scm_smob_apply_0_021; break;
    default:
      apply_0 = scm_smob_apply_0_error; break;
    }

  switch (type)
    {
    case SCM_GSUBR_MAKTYPE (1, 0, 0):
    case SCM_GSUBR_MAKTYPE (0, 1, 0):
      apply_1 = apply; break;
    case SCM_GSUBR_MAKTYPE (1, 1, 0):
    case SCM_GSUBR_MAKTYPE (0, 2, 0):
      apply_1 = scm_smob_apply_1_020; break;
    case SCM_GSUBR_MAKTYPE (1, 2, 0):
    case SCM_GSUBR_MAKTYPE (0, 3, 0):
      apply_1 = scm_smob_apply_1_030; break;
    case SCM_GSUBR_MAKTYPE (0, 0, 1):
      apply_1 = scm_smob_apply_1_001; break;
    case SCM_GSUBR_MAKTYPE (1, 0, 1):
    case SCM_GSUBR_MAKTYPE (0, 1, 1):
      apply_1 = scm_smob_apply_1_011; break;
    case SCM_GSUBR_MAKTYPE (1, 1, 1):
    case SCM_GSUBR_MAKTYPE (0, 2, 1):
      apply_1 = scm_smob_apply_1_021; break;
    default:
      apply_1 = scm_smob_apply_1_error; break;
    }

  switch (type)
    {
    case SCM_GSUBR_MAKTYPE (2, 0, 0):
    case SCM_GSUBR_MAKTYPE (1, 1, 0):
    case SCM_GSUBR_MAKTYPE (0, 2, 0):
      apply_2 = apply; break;
    case SCM_GSUBR_MAKTYPE (2, 1, 0):
    case SCM_GSUBR_MAKTYPE (1, 2, 0):
    case SCM_GSUBR_MAKTYPE (0, 3, 0):
      apply_2 = scm_smob_apply_2_030; break;
    case SCM_GSUBR_MAKTYPE (0, 0, 1):
      apply_2 = scm_smob_apply_2_001; break;
    case SCM_GSUBR_MAKTYPE (1, 0, 1):
    case SCM_GSUBR_MAKTYPE (0, 1, 1):
      apply_2 = scm_smob_apply_2_011; break;
    case SCM_GSUBR_MAKTYPE (2, 0, 1):
    case SCM_GSUBR_MAKTYPE (1, 1, 1):
    case SCM_GSUBR_MAKTYPE (0, 2, 1):
      apply_2 = scm_smob_apply_2_021; break;
    default:
      apply_2 = scm_smob_apply_2_error; break;
    }

  switch (type)
    {
    case SCM_GSUBR_MAKTYPE (3, 0, 0):
    case SCM_GSUBR_MAKTYPE (2, 1, 0):
    case SCM_GSUBR_MAKTYPE (1, 2, 0):
    case SCM_GSUBR_MAKTYPE (0, 3, 0):
      apply_3 = scm_smob_apply_3_030; break;
    case SCM_GSUBR_MAKTYPE (0, 0, 1):
      apply_3 = scm_smob_apply_3_001; break;
    case SCM_GSUBR_MAKTYPE (1, 0, 1):
    case SCM_GSUBR_MAKTYPE (0, 1, 1):
      apply_3 = scm_smob_apply_3_011; break;
    case SCM_GSUBR_MAKTYPE (2, 0, 1):
    case SCM_GSUBR_MAKTYPE (1, 1, 1):
    case SCM_GSUBR_MAKTYPE (0, 2, 1):
      apply_3 = scm_smob_apply_3_021; break;
    default:
      apply_3 = scm_smob_apply_3_error; break;
    }

  scm_smobs[SCM_TC2SMOBNUM (tc)].apply   = apply;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
  scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;

  if (scm_smob_class)
    scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
}

SCM
scm_make_smob (scm_t_bits tc)
{
  long n = SCM_TC2SMOBNUM (tc);
  size_t size = scm_smobs[n].size;
  scm_t_bits data = (size > 0
		     ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
		     : 0);
  return scm_cell (tc, data);
}

/* {Initialization for the type of free cells}
 */

static int
free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  char buf[100];
  sprintf (buf, "#<freed cell %p; GC missed a reference>",
	   (void *) SCM_UNPACK (exp));
  scm_puts (buf, port);

#if (SCM_DEBUG_CELL_ACCESSES == 1)
  if (scm_debug_cell_accesses_p)
    abort();
#endif

  return 1;
}

void
scm_smob_prehistory ()
{
  long i;
  scm_t_bits tc;

  scm_numsmob = 0;
  for (i = 0; i < MAX_SMOB_COUNT; ++i)
    {
      scm_smobs[i].name       = 0;
      scm_smobs[i].size       = 0;
      scm_smobs[i].mark       = 0;
      scm_smobs[i].free       = 0;
      scm_smobs[i].print      = scm_smob_print;
      scm_smobs[i].equalp     = 0;
      scm_smobs[i].apply      = 0;
      scm_smobs[i].apply_0    = 0;
      scm_smobs[i].apply_1    = 0;
      scm_smobs[i].apply_2    = 0;
      scm_smobs[i].apply_3    = 0;
      scm_smobs[i].gsubr_type = 0;
    }

  /* WARNING: This scm_make_smob_type call must be done first.  */
  tc = scm_make_smob_type ("free", 0);
  scm_set_smob_print (tc, free_print);
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_SMOB_H
#define SCM_SMOB_H

/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"
#include "libguile/print.h"

/* This is the internal representation of a smob type */

typedef struct scm_smob_descriptor
{
  char const *name;
  size_t size;
  SCM (*mark) (SCM);
  size_t (*free) (SCM);
  int (*print) (SCM exp, SCM port, scm_print_state *pstate);
  SCM (*equalp) (SCM, SCM);
  SCM (*apply) ();
  SCM (*apply_0) (SCM);
  SCM (*apply_1) (SCM, SCM);
  SCM (*apply_2) (SCM, SCM, SCM);
  SCM (*apply_3) (SCM, SCM, SCM, SCM);
  int gsubr_type; /* Used in procprop.c */
} scm_smob_descriptor;

#define SCM_NEWSMOB(z, tc, data) \
do { \
  z = scm_cell ((tc), (scm_t_bits) (data)); \
} while (0)

#define SCM_RETURN_NEWSMOB(tc, data) \
  do { SCM __SCM_smob_answer; \
       SCM_NEWSMOB (__SCM_smob_answer, (tc), (data)); \
       return __SCM_smob_answer; \
  } while (0)

#define SCM_NEWSMOB2(z, tc, data1, data2) \
do { \
  z = scm_double_cell ((tc), (scm_t_bits)(data1), (scm_t_bits)(data2), 0); \
} while (0)

#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \
  do { SCM __SCM_smob_answer; \
       SCM_NEWSMOB2 (__SCM_smob_answer, (tc), (data1), (data2)); \
       return __SCM_smob_answer; \
  } while (0)

#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \
do { \
  z = scm_double_cell ((tc), (scm_t_bits)(data1), \
                       (scm_t_bits)(data2), (scm_t_bits)(data3)); \
} while (0)

#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \
  do { SCM __SCM_smob_answer; \
       SCM_NEWSMOB3 (__SCM_smob_answer, (tc), (data1), (data2), (data3)); \
       return __SCM_smob_answer; \
  } while (0)

#define SCM_SMOB_FLAGS(x)               (SCM_CELL_WORD_0 (x) >> 16)
#define SCM_SMOB_DATA(x)		(SCM_CELL_WORD_1 (x))
#define SCM_SMOB_DATA_2(x)		(SCM_CELL_WORD_2 (x))
#define SCM_SMOB_DATA_3(x)		(SCM_CELL_WORD_3 (x))
#define SCM_SET_SMOB_DATA(x, data)	(SCM_SET_CELL_WORD_1 ((x), (data)))
#define SCM_SET_SMOB_DATA_2(x, data)	(SCM_SET_CELL_WORD_2 ((x), (data)))
#define SCM_SET_SMOB_DATA_3(x, data)	(SCM_SET_CELL_WORD_3 ((x), (data)))
#define SCM_SET_SMOB_FLAGS(x, data)     (scm_i_set_smob_flags((x),(data)<<16))

#define SCM_SMOB_OBJECT(x)		(SCM_CELL_OBJECT_1 (x))
#define SCM_SMOB_OBJECT_2(x)	        (SCM_CELL_OBJECT_2 (x))
#define SCM_SMOB_OBJECT_3(x)	        (SCM_CELL_OBJECT_3 (x))
#define SCM_SET_SMOB_OBJECT(x,obj)	(SCM_SET_CELL_OBJECT_1 ((x), (obj)))
#define SCM_SET_SMOB_OBJECT_2(x,obj)    (SCM_SET_CELL_OBJECT_2 ((x), (obj)))
#define SCM_SET_SMOB_OBJECT_3(x,obj)    (SCM_SET_CELL_OBJECT_3 ((x), (obj)))
#define SCM_SMOB_OBJECT_LOC(x)		(SCM_CELL_OBJECT_LOC ((x), 1))
#define SCM_SMOB_OBJECT_2_LOC(x)	(SCM_CELL_OBJECT_LOC ((x), 2))
#define SCM_SMOB_OBJECT_3_LOC(x)	(SCM_CELL_OBJECT_LOC ((x), 3))

#define SCM_TC2SMOBNUM(x)		(0x0ff & ((x) >> 8))
#define SCM_SMOBNUM(x)			(SCM_TC2SMOBNUM (SCM_CELL_TYPE (x)))
/* SCM_SMOBNAME can be 0 if name is missing */
#define SCM_SMOBNAME(smobnum)		(scm_smobs[smobnum].name)
#define SCM_SMOB_PREDICATE(tag, obj)	SCM_TYP16_PREDICATE (tag, obj)
#define SCM_SMOB_DESCRIPTOR(x)		(scm_smobs[SCM_SMOBNUM (x)])
#define SCM_SMOB_APPLICABLE_P(x)	(SCM_SMOB_DESCRIPTOR (x).apply)
#define SCM_SMOB_APPLY_0(x)		(SCM_SMOB_DESCRIPTOR (x).apply_0 (x))
#define SCM_SMOB_APPLY_1(x, a1)		(SCM_SMOB_DESCRIPTOR (x).apply_1 (x, (a1)))
#define SCM_SMOB_APPLY_2(x, a1, a2)	(SCM_SMOB_DESCRIPTOR (x).apply_2 (x, (a1), (a2)))
#define SCM_SMOB_APPLY_3(x, a1, a2, rst)	(SCM_SMOB_DESCRIPTOR (x).apply_3 (x, (a1), (a2), (rst)))

SCM_API long scm_numsmob;
SCM_API scm_smob_descriptor scm_smobs[];

SCM_API void scm_i_set_smob_flags (SCM x, scm_t_bits data);

SCM_API SCM scm_mark0 (SCM ptr);
SCM_API SCM scm_markcdr (SCM ptr);
SCM_API size_t scm_free0 (SCM ptr);
SCM_API size_t scm_smob_free (SCM obj);
SCM_API int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate);

/* The following set of functions is the standard way to create new
 * SMOB types.
 *
 * Create a type tag using `scm_make_smob_type', accept default values
 * for mark, free, print and/or equalp functions, or set your own
 * values using `scm_set_smob_xxx'.
 */

SCM_API scm_t_bits scm_make_smob_type (char const *name, size_t size);

SCM_API void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM));
SCM_API void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM));
SCM_API void scm_set_smob_print (scm_t_bits tc,
				 int (*print) (SCM, SCM, scm_print_state*));
SCM_API void scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM));
SCM_API void scm_set_smob_apply (scm_t_bits tc,
				 SCM (*apply) (),
				 unsigned int req,
				 unsigned int opt,
				 unsigned int rst);

SCM_API void scm_assert_smob_type (scm_t_bits tag, SCM val);

/* Function for creating smobs */

SCM_API SCM scm_make_smob (scm_t_bits tc);

SCM_API void scm_smob_prehistory (void);

#endif  /* SCM_SMOB_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_SNARF_H
#define SCM_SNARF_H

/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* Macros for snarfing initialization actions from C source. */

#if defined(__cplusplus) || defined(GUILE_CPLUSPLUS_SNARF)

/* This used to be "SCM (*)(...)" but GCC on RedHat 7.1 doesn't seem
   to like it.
 */
#define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)()

#else
#define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)()
#endif

/* Generic macros to be used in user macro definitions.
 *
 * For example, in order to define a macro which creates ints and
 * initializes them to the result of foo (), do:
 *
 *   #define SCM_FOO(NAME) \
 *     SCM_SNARF_HERE (int NAME) \
 *     SCM_SNARF_INIT (NAME = foo ())
 *
 * The SCM_SNARF_INIT text goes into the corresponding .x file
 * up through the first occurrence of SCM_SNARF_DOC_START on that
 * line, if any.
 */

#ifdef SCM_MAGIC_SNARF_INITS
# define SCM_SNARF_HERE(X)
# define SCM_SNARF_INIT(X) ^^ X ^:^
# define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
#else
# ifdef SCM_MAGIC_SNARF_DOCS
#  define SCM_SNARF_HERE(X)
#  define SCM_SNARF_INIT(X)
#  define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) \
^^ { \
cname CNAME ^^ \
fname FNAME ^^ \
type TYPE ^^ \
location __FILE__ __LINE__ ^^ \
arglist ARGLIST ^^ \
argsig REQ OPT VAR ^^ \
DOCSTRING ^^ }
# else
#  define SCM_SNARF_HERE(X) X
#  define SCM_SNARF_INIT(X)
#  define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
# endif
#endif

#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_INIT(\
scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
                    (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)

#define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
static SCM g_ ## FNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_INIT(\
g_ ## FNAME = SCM_PACK (0); \
scm_c_define_gsubr_with_generic (s_ ## FNAME, REQ, OPT, VAR, \
                    		 (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME, \
				 &g_ ## FNAME); \
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)

#define SCM_DEFINE_PUBLIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_INIT(\
scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
                    (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \
scm_c_export (s_ ## FNAME, NULL); \
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)

#define SCM_DEFINE1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_INIT(scm_c_define_subr (s_ ## FNAME, TYPE, FNAME); ) \
SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING)

#define SCM_PRIMITIVE_GENERIC_1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
static SCM g_ ## FNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_INIT(\
g_ ## FNAME = SCM_PACK (0); \
scm_c_define_subr_with_generic (s_ ## FNAME, TYPE, FNAME, &g_ ## FNAME); \
)\
SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING)

#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN)  \
SCM_SNARF_HERE(static const char RANAME[]=STR) \
SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \
                                   (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN))

#define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN)  \
SCM_SNARF_HERE(static const char RANAME[]=STR) \
SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \
                                   (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN);) \
SCM_SNARF_DOCS(register, CFN, STR, (), REQ, OPT, VAR, \
               "implemented by the C function \"" #CFN "\"")

#define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF)  \
SCM_SNARF_HERE(\
static const char RANAME[]=STR;\
static SCM GF \
)SCM_SNARF_INIT(\
GF = SCM_PACK (0);  /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \
scm_c_define_gsubr_with_generic (RANAME, REQ, OPT, VAR, \
                                 (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \
)

#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
SCM_SNARF_HERE(static const char RANAME[]=STR) \
SCM_SNARF_INIT(\
scm_c_define_subr (RANAME, TYPE, (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN) \
)

#define SCM_GPROC1(RANAME, STR, TYPE, CFN, GF) \
SCM_SNARF_HERE(\
static const char RANAME[]=STR; \
static SCM GF \
)SCM_SNARF_INIT(\
GF = SCM_PACK (0);  /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \
scm_c_define_subr_with_generic (RANAME, TYPE, \
                                (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \
)

#define SCM_SYNTAX(RANAME, STR, TYPE, CFN)  \
SCM_SNARF_HERE(static const char RANAME[]=STR)\
SCM_SNARF_INIT(scm_make_synt (RANAME, TYPE, CFN))

#define SCM_SYMBOL(c_name, scheme_name) \
SCM_SNARF_HERE(static SCM c_name) \
SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol (scheme_name)))

#define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \
SCM_SNARF_HERE(SCM c_name) \
SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol (scheme_name)))

#define SCM_KEYWORD(c_name, scheme_name) \
SCM_SNARF_HERE(static SCM c_name) \
SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_keyword (scheme_name)))

#define SCM_GLOBAL_KEYWORD(c_name, scheme_name) \
SCM_SNARF_HERE(SCM c_name) \
SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_keyword (scheme_name)))

#define SCM_VARIABLE(c_name, scheme_name) \
SCM_SNARF_HERE(static SCM c_name) \
SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));)

#define SCM_GLOBAL_VARIABLE(c_name, scheme_name) \
SCM_SNARF_HERE(SCM c_name) \
SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));)

#define SCM_VARIABLE_INIT(c_name, scheme_name, init_val) \
SCM_SNARF_HERE(static SCM c_name) \
SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));)

#define SCM_GLOBAL_VARIABLE_INIT(c_name, scheme_name, init_val) \
SCM_SNARF_HERE(SCM c_name) \
SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));)

#define SCM_MUTEX(c_name) \
SCM_SNARF_HERE(static scm_t_mutex c_name) \
SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_mutex))

#define SCM_GLOBAL_MUTEX(c_name) \
SCM_SNARF_HERE(scm_t_mutex c_name) \
SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_mutex))

#define SCM_REC_MUTEX(c_name) \
SCM_SNARF_HERE(static scm_t_rec_mutex c_name) \
SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex))

#define SCM_GLOBAL_REC_MUTEX(c_name) \
SCM_SNARF_HERE(scm_t_rec_mutex c_name) \
SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex))

#define SCM_SMOB(tag, scheme_name, size) \
SCM_SNARF_HERE(static scm_t_bits tag) \
SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)

#define SCM_GLOBAL_SMOB(tag, scheme_name, size) \
SCM_SNARF_HERE(scm_t_bits tag) \
SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)

#define SCM_SMOB_MARK(tag, c_name, arg) \
SCM_SNARF_HERE(static SCM c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)

#define SCM_GLOBAL_SMOB_MARK(tag, c_name, arg) \
SCM_SNARF_HERE(SCM c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)

#define SCM_SMOB_FREE(tag, c_name, arg) \
SCM_SNARF_HERE(static size_t c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));)

#define SCM_GLOBAL_SMOB_FREE(tag, c_name, arg) \
SCM_SNARF_HERE(size_t c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));)

#define SCM_SMOB_PRINT(tag, c_name, obj, port, pstate) \
SCM_SNARF_HERE(static int c_name(SCM obj, SCM port, scm_print_state* pstate)) \
SCM_SNARF_INIT(scm_set_smob_print((tag), (c_name));)

#define SCM_GLOBAL_SMOB_PRINT(tag, c_name, obj, port, pstate) \
SCM_SNARF_HERE(int c_name(SCM obj, SCM port, scm_print_state* pstate)) \
SCM_SNARF_INIT(scm_set_smob_print((tag), (c_name));)

#define SCM_SMOB_EQUALP(tag, c_name, obj1, obj2) \
SCM_SNARF_HERE(static SCM c_name(SCM obj1, SCM obj2)) \
SCM_SNARF_INIT(scm_set_smob_equalp((tag), (c_name));)

#define SCM_GLOBAL_SMOB_EQUALP(tag, c_name, obj1, obj2) \
SCM_SNARF_HERE(SCM c_name(SCM obj1, SCM obj2)) \
SCM_SNARF_INIT(scm_set_smob_equalp((tag), (c_name));)

#define SCM_SMOB_APPLY(tag, c_name, req, opt, rest, arglist) \
SCM_SNARF_HERE(static SCM c_name arglist) \
SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)

#define SCM_GLOBAL_SMOB_APPLY(tag, c_name, req, opt, rest, arglist) \
SCM_SNARF_HERE(SCM c_name arglist) \
SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)

#ifdef SCM_MAGIC_SNARF_DOCS
#undef SCM_ASSERT
#define SCM_ASSERT(_cond, _arg, _pos, _subr) ^^ argpos _arg _pos __LINE__ ^^
#endif /* SCM_MAGIC_SNARF_DOCS */

#endif  /* SCM_SNARF_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/