code:
/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 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 3 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 <version-etc.h>

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/feature.h"
#include "libguile/load.h"
#include "libguile/private-gc.h" /* scm_getenv_int */
#include "libguile/read.h"
#include "libguile/script.h"
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/validate.h"
#include "libguile/version.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]... [FILE]...\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\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"
           "  --autocompile  compile source files automatically\n"
           "  --no-autocompile  disable automatic source file compilation\n"
           "                 Default is to enable autocompilation of source\n"
           "                 files.\n"
	   "  -q             inhibit loading of user init file\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",
           scm_usage_name);

  emit_bug_reporting_address ();

  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_ice_9, "ice-9");
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_sys_load_should_autocompile, "%load-should-autocompile");
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 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;
	}

      /* Do autocompile on/off now, because the form itself might need this
         decision. */
      else if (! strcmp (argv[i], "--autocompile"))
        scm_variable_set_x (scm_c_lookup ("%load-should-autocompile"),
                            SCM_BOOL_T);

      else if (! strcmp (argv[i], "--no-autocompile"))
        scm_variable_set_x (scm_c_lookup ("%load-should-autocompile"),
                            SCM_BOOL_F);

      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.  */
	  version_etc (stdout, scm_usage_name, PACKAGE_NAME, PACKAGE_VERSION,
		       /* XXX: Use gettext for the string below.  */
		       "the Guile developers", NULL);
	  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);

  /* 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_list_1 (scm_list_3
                                   (sym_at,
                                    scm_list_2 (sym_ice_9, sym_top_repl),
                                    sym_top_repl)),
                       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);

    /* Wrap the expression in a prompt. */
    val = scm_list_2 (scm_list_3 (scm_sym_at,
                                      scm_list_2 (scm_from_locale_symbol ("ice-9"),
                                                  scm_from_locale_symbol ("control")),
                                      scm_from_locale_symbol ("%")),
                      val);

#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, 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 3 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_INTERNAL void scm_init_script (void);

#endif  /* SCM_SCRIPT_H */

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

license: mit


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2009 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 3 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

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;

      /* allocate before fork */
      execargv = scm_i_allocate_string_pointers (args);

      /* 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.  */
          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));

          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, 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 3 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_INTERNAL 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, 2009, 2010 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 3 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/goops.h"
#include "libguile/instructions.h"
#include "libguile/objcodes.h"
#include "libguile/programs.h"

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

#include "libguile/smob.h"

#include "libguile/bdw-gc.h"
#include <gc/gc_mark.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 SCM_I_MAX_SMOB_TYPE_COUNT

long scm_numsmob;
scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];

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;
}

/* {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}
 */

#ifdef WORDS_BIGENDIAN
#define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40
#define META_HEADER    0, 0, 0, 32, 0, 0, 0, 0
#else
#define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0
#define META_HEADER    32, 0, 0, 0, 0, 0, 0, 0
#endif

/* This code is the same as in gsubr.c, except we use smob_call instead of
   struct_call. */

/* A: req; B: opt; C: rest */
#define A(nreq)                                                         \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */  \
  /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
  /* 5 */ scm_op_smob_call, nreq, /* and call (will return value as well) */ \
  /* 7 */ scm_op_nop,                                                   \
  /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,               \
  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  /* 16 */ META (3, 7, nreq, 0, 0)

#define B(nopt)                                                         \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */          \
  /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */  \
  /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
  /* 8 */ scm_op_smob_call, nopt, /* and call (will return value as well) */ \
  /* 10 */ scm_op_nop, scm_op_nop,                                      \
  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  /* 16 */ META (6, 10, 0, nopt, 0)

#define C()                                                             \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */       \
  /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
  /* 5 */ scm_op_smob_call, 1, /* and call (will return value as well) */ \
  /* 7 */ scm_op_nop,                                                   \
  /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,               \
  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  /* 16 */ META (3, 7, 0, 0, 1)

#define AB(nreq, nopt)                                                  \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
  /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */     \
  /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \
  /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
  /* 11 */ scm_op_smob_call, nreq+nopt, /* and call (will return value as well) */ \
  /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop,                          \
  /* 16 */ META (9, 13, nreq, nopt, 0)

#define AC(nreq)                                                        \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
  /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */               \
  /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
  /* 8 */ scm_op_smob_call, nreq+1, /* and call (will return value as well) */ \
  /* 10 */ scm_op_nop, scm_op_nop,                                      \
  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  /* 16 */ META (6, 10, nreq, 0, 1)

#define BC(nopt)                                                        \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */          \
  /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */               \
  /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
  /* 8 */ scm_op_smob_call, nopt+1, /* and call (will return value as well) */ \
  /* 10 */ scm_op_nop, scm_op_nop,                                      \
  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  /* 16 */ META (6, 10, 0, nopt, 1)

#define ABC(nreq, nopt)                                                 \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
  /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */     \
  /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */          \
  /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
  /* 11 */ scm_op_smob_call, nreq+nopt+1, /* and call (will return value as well) */ \
  /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop,                          \
  /* 16 */ META (9, 13, nreq, nopt, 1)

#define META(start, end, nreq, nopt, rest)                              \
  META_HEADER,                                                          \
  /* 0 */ scm_op_make_eol, /* bindings */                               \
  /* 1 */ scm_op_make_eol, /* sources */                                \
  /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
  /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */    \
  /* 8 */ scm_op_make_int8, nopt, /* N optionals */                     \
  /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */ \
  /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */         \
  /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
  /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
  /* 25 */ scm_op_object_ref, 1, /* the name from the object table */   \
  /* 27 */ scm_op_cons, /* make a pair for the properties */            \
  /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
  /* 31 */ scm_op_return /* and return */                               \
  /* 32 */

static const struct
{
  scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
  const scm_t_uint8 bytes[16 * (sizeof (struct scm_objcode) + 16
                                + sizeof (struct scm_objcode) + 32)];
} raw_bytecode = {
  0,
  {
    /* Use the elisp macros from gsubr.c */
    /* C-u 3 M-x generate-bytecodes RET */
    /* 0 arguments */
    A(0),
    /* 1 arguments */
    A(1), B(1), C(),
    /* 2 arguments */
    A(2), AB(1,1), B(2), AC(1), BC(1),
    /* 3 arguments */
    A(3), AB(2,1), AB(1,2), B(3), AC(2), ABC(1,1), BC(2)
  }
};

#undef A
#undef B
#undef C
#undef AB
#undef AC
#undef BC
#undef ABC
#undef OBJCODE_HEADER
#undef META_HEADER
#undef META

#define STATIC_OBJCODE_TAG                                      \
  SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))

static const struct
{
  scm_t_uint64 dummy; /* alignment */
  scm_t_cell cells[16 * 2]; /* 4*4 double cells */
} objcode_cells = {
  0,
  /* C-u 3 M-x generate-objcode-cells RET */
  {
    /* 0 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 1 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 2 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 512) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 3 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) },
    { SCM_BOOL_F, SCM_PACK (0) }
  }
};

static const SCM scm_smob_objcode_trampolines[16] = {
  /* C-u 3 M-x generate-objcodes RET */
  /* 0 arguments */
  SCM_PACK (objcode_cells.cells+0),

  /* 1 arguments */
  SCM_PACK (objcode_cells.cells+2),
  SCM_PACK (objcode_cells.cells+4),
  SCM_PACK (objcode_cells.cells+6),

  /* 2 arguments */
  SCM_PACK (objcode_cells.cells+8),
  SCM_PACK (objcode_cells.cells+10),
  SCM_PACK (objcode_cells.cells+12),
  SCM_PACK (objcode_cells.cells+14),
  SCM_PACK (objcode_cells.cells+16),

  /* 3 arguments */
  SCM_PACK (objcode_cells.cells+18),
  SCM_PACK (objcode_cells.cells+20),
  SCM_PACK (objcode_cells.cells+22),
  SCM_PACK (objcode_cells.cells+24),
  SCM_PACK (objcode_cells.cells+26),
  SCM_PACK (objcode_cells.cells+28),
  SCM_PACK (objcode_cells.cells+30)
};

/* (nargs * nargs) + nopt + rest * (nargs + 1) */
#define SCM_SMOB_OBJCODE_TRAMPOLINE(nreq,nopt,rest)                     \
  scm_smob_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
                               + nopt + rest * (nreq + nopt + rest + 1)]

static SCM
scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt,
                             unsigned int rest)
{
  if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 3))
    scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest));

  return SCM_SMOB_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
}

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;
  scm_smobs[new_smob].size = size;

  /* Make a class object if Goops is present. */
  if (SCM_UNPACK (scm_smob_class[0]) != 0)
    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_smobs[SCM_TC2SMOBNUM (tc)].apply   = apply;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode
    = scm_smob_objcode_trampoline (req, opt, rst);

  if (SCM_UNPACK (scm_smob_class[0]) != 0)
    scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
}

static SCM tramp_weak_map = SCM_BOOL_F;
SCM
scm_i_smob_apply_trampoline (SCM smob)
{
  /* could use hashq-create-handle!, but i don't know what to do if it returns a
     weak pair */
  SCM tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);

  if (scm_is_true (tramp))
    return tramp;
  else
    {
      const char *name;
      SCM objtable;

      name = SCM_SMOBNAME (SCM_SMOBNUM (smob));
      if (!name)
        name = "smob-apply";
      objtable = scm_c_make_vector (2, SCM_UNDEFINED);
      SCM_SIMPLE_VECTOR_SET (objtable, 0, smob);
      SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name));
      tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode,
                                objtable, SCM_BOOL_F);
      scm_hashq_set_x (tramp_weak_map, smob, tramp);
      return tramp;
    }
}

SCM
scm_make_smob (scm_t_bits tc)
{
  scm_t_bits 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);

  SCM_RETURN_NEWSMOB (tc, data);
}

/* Marking SMOBs using user-supplied mark procedures.  */

/* The GC kind used for SMOB types that provide a custom mark procedure.  */
static int smob_gc_kind;

/* The generic SMOB mark procedure that gets called for SMOBs allocated with
   `scm_i_new_smob_with_mark_proc ()'.  */
static struct GC_ms_entry *
smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
	   struct GC_ms_entry *mark_stack_limit, GC_word env)
{
  register SCM cell;
  register scm_t_bits tc, smobnum;

  cell = PTR2SCM (addr);

  if (SCM_TYP7 (cell) != scm_tc7_smob)
    /* It is likely that the GC passed us a pointer to a free-list element
       which we must ignore (see warning in `gc/gc_mark.h').  */
    return mark_stack_ptr;

  tc = SCM_CELL_WORD_0 (cell);
  smobnum = SCM_TC2SMOBNUM (tc);

  if (smobnum >= scm_numsmob)
    /* The first word looks corrupt.  */
    abort ();

  mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
				     mark_stack_ptr,
				     mark_stack_limit, NULL);
  mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
				     mark_stack_ptr,
				     mark_stack_limit, NULL);
  mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
				     mark_stack_ptr,
				     mark_stack_limit, NULL);

  if (scm_smobs[smobnum].mark)
    {
      SCM obj;

      SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
      SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;

      /* Invoke the SMOB's mark procedure, which will in turn invoke
	 `scm_gc_mark ()', which may modify `current_mark_stack_ptr'.  */
      obj = scm_smobs[smobnum].mark (cell);

      mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;

      if (SCM_NIMP (obj))
	/* Mark the returned object.  */
	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
					   mark_stack_ptr,
					   mark_stack_limit, NULL);

      SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL;
      SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL;
    }

  return mark_stack_ptr;

}

/* Mark object O.  We assume that this function is only called during the
   mark phase, i.e., from within `smob_mark ()' or one of its
   descendents.  */
void
scm_gc_mark (SCM o)
{
#define CURRENT_MARK_PTR						 \
  ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
#define CURRENT_MARK_LIMIT						   \
  ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))

  if (SCM_NIMP (o))
    {
      /* At this point, the `current_mark_*' fields of the current thread
	 must be defined (they are set in `smob_mark ()').  */
      register struct GC_ms_entry *mark_stack_ptr;

      if (!CURRENT_MARK_PTR)
	/* The function was not called from a mark procedure.  */
	abort ();

      mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
					 CURRENT_MARK_PTR, CURRENT_MARK_LIMIT,
					 NULL);
      SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
    }
#undef CURRENT_MARK_PTR
#undef CURRENT_MARK_LIMIT
}

/* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
   provide a custom mark procedure and it will be honored.  */
SCM
scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1,
			       scm_t_bits data2, scm_t_bits data3)
{
  /* Return a double cell.  */
  SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell),
					  smob_gc_kind));

  SCM_SET_CELL_WORD_3 (cell, data3);
  SCM_SET_CELL_WORD_2 (cell, data2);
  SCM_SET_CELL_WORD_1 (cell, data1);
  SCM_SET_CELL_WORD_0 (cell, tc);

  return cell;
}

/* Finalize SMOB by calling its SMOB type's free function, if any.  */
void
scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
{
  SCM smob;
  size_t (* free_smob) (SCM);

  smob = PTR2SCM (ptr);
#if 0
  printf ("finalizing SMOB %p (smobnum: %u)\n",
	  ptr, SCM_SMOBNUM (smob));
#endif

  free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
  if (free_smob)
    free_smob (smob);
}

void
scm_smob_prehistory ()
{
  long i;

  smob_gc_kind = GC_new_kind (GC_new_free_list (),
			      GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
			      0,
			      /* Clear new objects.  As of version 7.1, libgc
				 doesn't seem to support passing 0 here.  */
			      1);

  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_trampoline_objcode = SCM_BOOL_F;
    }

  tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
}

/*
  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, 2009, 2010 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 3 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"

#include "libguile/bdw-gc.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_trampoline_objcode;
} scm_smob_descriptor;

SCM_API SCM scm_i_new_smob_with_mark_proc (scm_t_bits tc,
					   scm_t_bits, scm_t_bits, scm_t_bits);

#define SCM_NEWSMOB(z, tc, data)					  \
do									  \
  {									  \
    register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc);			  \
    z = (scm_smobs[_smobnum].mark					  \
	 ? scm_i_new_smob_with_mark_proc ((tc), (scm_t_bits)(data),	  \
					  0, 0)				  \
	 : scm_cell (tc, (scm_t_bits)(data)));				  \
    if (scm_smobs[_smobnum].free)					  \
      {									  \
	GC_finalization_proc _prev_finalizer;				  \
	GC_PTR _prev_finalizer_data;					  \
									  \
	GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \
					NULL,				  \
					&_prev_finalizer,		  \
					&_prev_finalizer_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)	\
  SCM_NEWSMOB3 (z, tc, data1, data2, 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									  \
  {									  \
    register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc);			  \
    z = (scm_smobs[_smobnum].mark					  \
	 ? scm_i_new_smob_with_mark_proc (tc, (scm_t_bits)(data1),	  \
					  (scm_t_bits)(data2),		  \
					  (scm_t_bits)(data3))		  \
	 : scm_double_cell ((tc), (scm_t_bits)(data1),			  \
			    (scm_t_bits)(data2),			  \
			    (scm_t_bits)(data3)));			  \
    if (scm_smobs[_smobnum].free)					  \
      {									  \
	GC_finalization_proc _prev_finalizer;				  \
	GC_PTR _prev_finalizer_data;					  \
									  \
	GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \
					NULL,				  \
					&_prev_finalizer,		  \
					&_prev_finalizer_data);		  \
      }									  \
  }									  \
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_DATA_N(x, n)		(SCM_CELL_WORD ((x), (n)))
#define SCM_SET_SMOB_DATA_N(x, n, data)	(SCM_SET_CELL_WORD ((x), (n), (data)))

#define SCM_SMOB_DATA_0(x)		(SCM_SMOB_DATA_N ((x), 0))
#define SCM_SMOB_DATA_1(x)		(SCM_SMOB_DATA_N ((x), 1))
#define SCM_SMOB_DATA_2(x)		(SCM_SMOB_DATA_N ((x), 2))
#define SCM_SMOB_DATA_3(x)		(SCM_SMOB_DATA_N ((x), 3))
#define SCM_SET_SMOB_DATA_0(x, data)	(SCM_SET_SMOB_DATA_N ((x), 0, (data)))
#define SCM_SET_SMOB_DATA_1(x, data)	(SCM_SET_SMOB_DATA_N ((x), 1, (data)))
#define SCM_SET_SMOB_DATA_2(x, data)	(SCM_SET_SMOB_DATA_N ((x), 2, (data)))
#define SCM_SET_SMOB_DATA_3(x, data)	(SCM_SET_SMOB_DATA_N ((x), 3, (data)))

#define SCM_SMOB_FLAGS(x)               (SCM_SMOB_DATA_0 (x) >> 16)
#define SCM_SMOB_DATA(x)		(SCM_SMOB_DATA_1 (x))
#define SCM_SET_SMOB_FLAGS(x, data)     (SCM_SET_SMOB_DATA_0 ((x), (SCM_CELL_TYPE (x)&0xffff)|((data)<<16)))
#define SCM_SET_SMOB_DATA(x, data)	(SCM_SET_SMOB_DATA_1 ((x), (data)))

#define SCM_SMOB_OBJECT_N(x,n)		(SCM_CELL_OBJECT ((x), (n)))
#define SCM_SET_SMOB_OBJECT_N(x,n,obj)	(SCM_SET_CELL_OBJECT ((x), (n), (obj)))
#define SCM_SMOB_OBJECT_N_LOC(x,n)	(SCM_CELL_OBJECT_LOC ((x), (n)))

/*#define SCM_SMOB_OBJECT_0(x)		(SCM_SMOB_OBJECT_N ((x), 0))*/
#define SCM_SMOB_OBJECT_1(x)		(SCM_SMOB_OBJECT_N ((x), 1))
#define SCM_SMOB_OBJECT_2(x)		(SCM_SMOB_OBJECT_N ((x), 2))
#define SCM_SMOB_OBJECT_3(x)		(SCM_SMOB_OBJECT_N ((x), 3))
/*#define SCM_SET_SMOB_OBJECT_0(x,obj)	(SCM_SET_SMOB_OBJECT_N ((x), 0, (obj)))*/
#define SCM_SET_SMOB_OBJECT_1(x,obj)	(SCM_SET_SMOB_OBJECT_N ((x), 1, (obj)))
#define SCM_SET_SMOB_OBJECT_2(x,obj)	(SCM_SET_SMOB_OBJECT_N ((x), 2, (obj)))
#define SCM_SET_SMOB_OBJECT_3(x,obj)	(SCM_SET_SMOB_OBJECT_N ((x), 3, (obj)))
#define SCM_SMOB_OBJECT_0_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 0)))
#define SCM_SMOB_OBJECT_1_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 1)))
#define SCM_SMOB_OBJECT_2_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 2)))
#define SCM_SMOB_OBJECT_3_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 3)))

#define SCM_SMOB_OBJECT(x)		(SCM_SMOB_OBJECT_1 (x))
#define SCM_SET_SMOB_OBJECT(x,obj)	(SCM_SET_SMOB_OBJECT_1 ((x), (obj)))
#define SCM_SMOB_OBJECT_LOC(x)		(SCM_SMOB_OBJECT_1_LOC (x)))

#define SCM_SMOB_TYPE_MASK		0xffff
#define SCM_SMOB_TYPE_BITS(tc)		(tc)
#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_call_0 (x))
#define SCM_SMOB_APPLY_1(x, a1)		(scm_call_1 (x, a1))
#define SCM_SMOB_APPLY_2(x, a1, a2)	(scm_call_2 (x, a1, a2))
#define SCM_SMOB_APPLY_3(x, a1, a2, rst) (scm_call_3 (x, a1, a2, a3))

/* Maximum number of SMOB types.  */
#define SCM_I_MAX_SMOB_TYPE_COUNT  256

SCM_API long scm_numsmob;
SCM_API scm_smob_descriptor scm_smobs[];

SCM_API void scm_i_finalize_smob (GC_PTR obj, GC_PTR 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 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_INTERNAL SCM scm_i_smob_apply_trampoline (SCM smob);

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, 2009, 2010 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 3 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

#if (defined SCM_ALIGNED) && (SCM_DEBUG_TYPING_STRICTNESS <= 1)
/* We support static allocation of some `SCM' objects.  */
# define SCM_SUPPORT_STATIC_ALLOCATION
#endif

/* C preprocessor token concatenation.  */
#define scm_i_paste(x, y)      x ## y
#define scm_i_paste3(a, b, c)  a ## b ## c

/* 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_GSUBR(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)

#ifdef SCM_SUPPORT_STATIC_ALLOCATION

/* Static subr allocation.  */
/* FIXME: how to verify that req + opt + rest < 11, all are positive, etc? */
#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING)	\
SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME);			\
SCM_SNARF_HERE(							        \
  static const char scm_i_paste (s_, FNAME) [] = PRIMNAME;		\
  SCM_API SCM FNAME ARGLIST;						\
  SCM_IMMUTABLE_POINTER (scm_i_paste (FNAME, __subr_foreign),           \
                         (scm_t_bits) &FNAME); /* the subr */           \
  SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable),         \
                           /* FIXME: directly be the foreign */         \
                           SCM_BOOL_F);                                 \
  /* FIXME: be immutable. grr */                                        \
  SCM_STATIC_PROGRAM (scm_i_paste (FNAME, __subr),			\
                      SCM_BOOL_F,                                       \
                      SCM_PACK (&scm_i_paste (FNAME, __raw_objtable)),  \
                      SCM_BOOL_F);                                      \
  SCM FNAME ARGLIST							\
)									\
SCM_SNARF_INIT(							\
  /* Initialize the foreign.  */                                        \
  scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __subr_foreign); \
  /* Initialize the procedure name (an interned symbol).  */		\
  scm_i_paste (FNAME, __raw_objtable)[3] = scm_i_paste (FNAME, __name); \
  /* Initialize the objcode trampoline.  */                             \
  SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1,                  \
                       scm_subr_objcode_trampoline (REQ, OPT, VAR));    \
									\
  /* Define the subr.  */						\
  scm_define (scm_i_paste (FNAME, __name), scm_i_paste (FNAME, __subr)); \
)									\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)

#else /* !SCM_SUPPORT_STATIC_ALLOCATION */

/* Always use the generic subr case.  */
#define SCM_DEFINE SCM_DEFINE_GSUBR

#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */

#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_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) \
)

#ifdef SCM_SUPPORT_STATIC_ALLOCATION

# define SCM_SYMBOL(c_name, scheme_name)				\
SCM_SNARF_HERE(								\
  SCM_IMMUTABLE_STRING (scm_i_paste (c_name, _string), scheme_name);	\
  static SCM c_name)							\
SCM_SNARF_INIT(								\
  c_name = scm_string_to_symbol (scm_i_paste (c_name, _string))		\
)

# define SCM_GLOBAL_SYMBOL(c_name, scheme_name)				\
SCM_SNARF_HERE(								\
  SCM_IMMUTABLE_STRING (scm_i_paste (c_name, _string), scheme_name);	\
  SCM c_name)								\
SCM_SNARF_INIT(								\
  c_name = scm_string_to_symbol (scm_i_paste (c_name, _string))		\
)

#else /* !SCM_SUPPORT_STATIC_ALLOCATION */

# define SCM_SYMBOL(c_name, scheme_name)				\
SCM_SNARF_HERE(static SCM c_name)					\
SCM_SNARF_INIT(c_name = 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_from_locale_symbol (scheme_name))

#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */

#define SCM_KEYWORD(c_name, scheme_name) \
SCM_SNARF_HERE(static SCM c_name) \
SCM_SNARF_INIT(c_name = 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_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_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_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_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_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));)

/* Low-level snarfing for static memory allocation.  */

#ifdef SCM_SUPPORT_STATIC_ALLOCATION

#define SCM_IMMUTABLE_CELL(c_name, car, cdr)		\
  static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell			\
       c_name ## _raw_scell =						\
  {                                                                     \
    SCM_PACK (car),                                                     \
    SCM_PACK (cdr)                                                      \
  };                                                                    \
  static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_scell)

#define SCM_IMMUTABLE_DOUBLE_CELL(c_name, car, cbr, ccr, cdr)		\
  static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell			\
  c_name ## _raw_cell [2] =						\
    {									\
      { SCM_PACK (car), SCM_PACK (cbr) },				\
      { SCM_PACK (ccr), SCM_PACK (cdr) }				\
    };									\
  static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_cell)

#define SCM_STATIC_DOUBLE_CELL(c_name, car, cbr, ccr, cdr)		\
  static SCM_ALIGNED (8) SCM_UNUSED scm_t_cell                          \
  c_name ## _raw_cell [2] =						\
    {									\
      { SCM_PACK (car), SCM_PACK (cbr) },				\
      { SCM_PACK (ccr), SCM_PACK (cdr) }				\
    };									\
  static SCM_UNUSED SCM c_name = SCM_PACK (& c_name ## _raw_cell)

#define SCM_IMMUTABLE_STRINGBUF(c_name, contents)	\
  static SCM_UNUSED const				\
  struct						\
  {							\
    scm_t_bits word_0;					\
    scm_t_bits word_1;					\
    const char buffer[sizeof (contents)];		\
  }							\
  c_name =						\
    {							\
      scm_tc7_stringbuf | SCM_I_STRINGBUF_F_SHARED,	\
      sizeof (contents) - 1,				\
      contents						\
    }

#define SCM_IMMUTABLE_STRING(c_name, contents)				\
  SCM_IMMUTABLE_STRINGBUF (scm_i_paste (c_name, _stringbuf), contents);	\
  SCM_IMMUTABLE_DOUBLE_CELL (c_name,					\
			     scm_tc7_ro_string,				\
			     (scm_t_bits) &scm_i_paste (c_name,		\
							_stringbuf),	\
			     (scm_t_bits) 0,				\
			     (scm_t_bits) sizeof (contents) - 1)

#define SCM_IMMUTABLE_POINTER(c_name, ptr)		\
  SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, ptr)

/* for primitive-generics, add a foreign to the end */
#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign)                        \
  static SCM_ALIGNED (8) SCM c_name[4] =                                \
  {                                                                     \
    SCM_PACK (scm_tc7_vector | (2 << 8)),                               \
    SCM_PACK (0),                                                       \
    foreign,                                                            \
    SCM_BOOL_F, /* the name */                                          \
  };									\

#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars)         \
  SCM_STATIC_DOUBLE_CELL (c_name,                                       \
                          scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE,	\
                          (scm_t_bits) objcode,                         \
                          (scm_t_bits) objtable,                        \
                          (scm_t_bits) freevars)

#endif /* SCM_SUPPORT_STATIC_ALLOCATION */

/* Documentation.  */

#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:
*/