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

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

#include <string.h>
#include <stdio.h>

#include "libguile/_scm.h"
#include "libguile/libpath.h"
#include "libguile/fports.h"
#include "libguile/read.h"
#include "libguile/eval.h"
#include "libguile/throw.h"
#include "libguile/alist.h"
#include "libguile/dynwind.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/modules.h"
#include "libguile/lang.h"
#include "libguile/chars.h"
#include "libguile/srfi-13.h"

#include "libguile/validate.h"
#include "libguile/load.h"
#include "libguile/fluids.h"

#include <sys/types.h>
#include <sys/stat.h>

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

#ifndef R_OK
#define R_OK 4
#endif

/* Loading a file, given an absolute filename.  */

/* Hook to run when we load a file, perhaps to announce the fact somewhere.
   Applied to the full name of the file.  */
static SCM *scm_loc_load_hook;

/* The current reader (a fluid).  */
static SCM the_reader = SCM_BOOL_F;
static size_t the_reader_fluid_num = 0;

SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
           (SCM filename),
	    "Load the file named @var{filename} and evaluate its contents in\n"
	    "the top-level environment. The load paths are not searched;\n"
	    "@var{filename} must either be a full pathname or be a pathname\n"
	    "relative to the current directory.  If the  variable\n"
	    "@code{%load-hook} is defined, it should be bound to a procedure\n"
	    "that will be called before any code is loaded.  See the\n"
	    "documentation for @code{%load-hook} later in this section.")
#define FUNC_NAME s_scm_primitive_load
{
  SCM hook = *scm_loc_load_hook;
  SCM_VALIDATE_STRING (1, filename);
  if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
    SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f",
		    SCM_EOL);

  if (!scm_is_false (hook))
    scm_call_1 (hook, filename);

  { /* scope */
    SCM port = scm_open_file (filename, scm_from_locale_string ("r"));
    scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
    scm_i_dynwind_current_load_port (port);

    while (1)
      {
	SCM reader, form;

	/* Lookup and use the current reader to read the next
	   expression. */
	reader = SCM_FAST_FLUID_REF (the_reader_fluid_num);
	if (reader == SCM_BOOL_F)
	  form = scm_read (port);
	else
	  form = scm_call_1 (reader, port);

	if (SCM_EOF_OBJECT_P (form))
	  break;

	scm_primitive_eval_x (form);
      }

    scm_dynwind_end ();
    scm_close_port (port);
  }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM
scm_c_primitive_load (const char *filename)
{
  return scm_primitive_load (scm_from_locale_string (filename));
}

/* Builtin path to scheme library files. */
#ifdef SCM_PKGDATA_DIR
SCM_DEFINE (scm_sys_package_data_dir, "%package-data-dir", 0, 0, 0,
            (),
	    "Return the name of the directory where Scheme packages, modules and\n"
	    "libraries are kept.  On most Unix systems, this will be\n"
	    "@samp{/usr/local/share/guile}.")
#define FUNC_NAME s_scm_sys_package_data_dir
{
  return scm_from_locale_string (SCM_PKGDATA_DIR);
}
#undef FUNC_NAME
#endif /* SCM_PKGDATA_DIR */

#ifdef SCM_LIBRARY_DIR
SCM_DEFINE (scm_sys_library_dir, "%library-dir", 0,0,0,
            (),
	    "Return the directory where the Guile Scheme library files are installed.\n"
	    "E.g., may return \"/usr/share/guile/1.3.5\".")
#define FUNC_NAME s_scm_sys_library_dir
{
  return scm_from_locale_string (SCM_LIBRARY_DIR);
}
#undef FUNC_NAME
#endif /* SCM_LIBRARY_DIR */

#ifdef SCM_SITE_DIR
SCM_DEFINE (scm_sys_site_dir, "%site-dir", 0,0,0,
            (),
	    "Return the directory where the Guile site files are installed.\n"
	    "E.g., may return \"/usr/share/guile/site\".")
#define FUNC_NAME s_scm_sys_site_dir
{
  return scm_from_locale_string (SCM_SITE_DIR);
}
#undef FUNC_NAME
#endif /* SCM_SITE_DIR */

/* Initializing the load path, and searching it.  */

/* List of names of directories we search for files to load.  */
static SCM *scm_loc_load_path;

/* List of extensions we try adding to the filenames.  */
static SCM *scm_loc_load_extensions;

SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0,
            (SCM path, SCM tail),
	    "Parse @var{path}, which is expected to be a colon-separated\n"
	    "string, into a list and return the resulting list with\n"
	    "@var{tail} appended. If @var{path} is @code{#f}, @var{tail}\n"
	    "is returned.")
#define FUNC_NAME s_scm_parse_path
{
#ifdef __MINGW32__
  SCM sep = SCM_MAKE_CHAR (';');
#else
  SCM sep = SCM_MAKE_CHAR (':');
#endif

  if (SCM_UNBNDP (tail))
    tail = SCM_EOL;
  return (scm_is_false (path)
	  ? tail
	  : scm_append_x (scm_list_2 (scm_string_split (path, sep), tail)));
}
#undef FUNC_NAME

/* Initialize the global variable %load-path, given the value of the
   SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
   GUILE_LOAD_PATH environment variable.  */
void
scm_init_load_path ()
{
  char *env;
  SCM path = SCM_EOL;

#ifdef SCM_LIBRARY_DIR
  path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR),
		     scm_from_locale_string (SCM_LIBRARY_DIR),
		     scm_from_locale_string (SCM_PKGDATA_DIR));
#endif /* SCM_LIBRARY_DIR */

  env = getenv ("GUILE_LOAD_PATH");
  if (env)
    path = scm_parse_path (scm_from_locale_string (env), path);

  *scm_loc_load_path = path;
}

SCM scm_listofnullstr;

/* Utility functions for assembling C strings in a buffer.
 */

struct stringbuf {
  char *buf, *ptr;
  size_t buf_len;
};

static void
stringbuf_free (void *data)
{
  struct stringbuf *buf = (struct stringbuf *)data;
  free (buf->buf);
}

static void
stringbuf_grow (struct stringbuf *buf)
{
  size_t ptroff = buf->ptr - buf->buf;
  buf->buf_len *= 2;
  buf->buf = scm_realloc (buf->buf, buf->buf_len);
  buf->ptr = buf->buf + ptroff;
}

static void
stringbuf_cat_locale_string (struct stringbuf *buf, SCM str)
{
  size_t max_len = buf->buf_len - (buf->ptr - buf->buf) - 1;
  size_t len = scm_to_locale_stringbuf (str, buf->ptr, max_len);
  if (len > max_len)
    {
      /* buffer is too small, double its size and try again.
       */
      stringbuf_grow (buf);
      stringbuf_cat_locale_string (buf, str);
    }
  else
    {
      /* string fits, terminate it and check for embedded '\0'.
       */
      buf->ptr[len] = '\0';
      if (strlen (buf->ptr) != len)
	scm_misc_error (NULL,
			"string contains #\\nul character: ~S",
			scm_list_1 (str));
      buf->ptr += len;
    }
}

static void
stringbuf_cat (struct stringbuf *buf, char *str)
{
  size_t max_len = buf->buf_len - (buf->ptr - buf->buf) - 1;
  size_t len = strlen (str);
  if (len > max_len)
    {
      /* buffer is too small, double its size and try again.
       */
      stringbuf_grow (buf);
      stringbuf_cat (buf, str);
    }
  else
    {
      /* string fits, copy it into buffer.
       */
      strcpy (buf->ptr, str);
      buf->ptr += len;
    }
}

/* Search PATH for a directory containing a file named FILENAME.
   The file must be readable, and not a directory.
   If we find one, return its full filename; otherwise, return #f.
   If FILENAME is absolute, return it unchanged.
   If given, EXTENSIONS is a list of strings; for each directory
   in PATH, we search for FILENAME concatenated with each EXTENSION.  */
SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0,
           (SCM path, SCM filename, SCM extensions),
	    "Search @var{path} for a directory containing a file named\n"
	    "@var{filename}. The file must be readable, and not a directory.\n"
	    "If we find one, return its full filename; otherwise, return\n"
	    "@code{#f}.  If @var{filename} is absolute, return it unchanged.\n"
	    "If given, @var{extensions} is a list of strings; for each\n"
	    "directory in @var{path}, we search for @var{filename}\n"
	    "concatenated with each @var{extension}.")
#define FUNC_NAME s_scm_search_path
{
  struct stringbuf buf;
  char *filename_chars;
  size_t filename_len;
  SCM result = SCM_BOOL_F;

  if (SCM_UNBNDP (extensions))
    extensions = SCM_EOL;

  scm_dynwind_begin (0);

  filename_chars = scm_to_locale_string (filename);
  filename_len = strlen (filename_chars);
  scm_dynwind_free (filename_chars);

  /* If FILENAME is absolute, return it unchanged.  */
#ifdef __MINGW32__
  if (((filename_len >= 1) &&
       (filename_chars[0] == '/' || filename_chars[0] == '\\')) ||
      ((filename_len >= 3) && filename_chars[1] == ':' &&
       ((filename_chars[0] >= 'a' && filename_chars[0] <= 'z') ||
	(filename_chars[0] >= 'A' && filename_chars[0] <= 'Z')) &&
       (filename_chars[2] == '/' || filename_chars[2] == '\\')))
#else
  if (filename_len >= 1 && filename_chars[0] == '/')
#endif
    {
      scm_dynwind_end ();
      return filename;
    }

  /* If FILENAME has an extension, don't try to add EXTENSIONS to it.  */
  {
    char *endp;

    for (endp = filename_chars + filename_len - 1;
	 endp >= filename_chars;
	 endp--)
      {
	if (*endp == '.')
	  {
	    /* This filename already has an extension, so cancel the
               list of extensions.  */
	    extensions = SCM_EOL;
	    break;
	  }
#ifdef __MINGW32__
	else if (*endp == '/' || *endp == '\\')
#else
	else if (*endp == '/')
#endif
	  /* This filename has no extension, so keep the current list
             of extensions.  */
	  break;
      }
  }

  /* This simplifies the loop below a bit.
   */
  if (scm_is_null (extensions))
    extensions = scm_listofnullstr;

  buf.buf_len = 512;
  buf.buf = scm_malloc (buf.buf_len);
  scm_dynwind_unwind_handler (stringbuf_free, &buf, SCM_F_WIND_EXPLICITLY);

  /* Try every path element.
   */
  for (; scm_is_pair (path); path = SCM_CDR (path))
    {
      SCM dir = SCM_CAR (path);
      SCM exts;
      size_t sans_ext_len;

      buf.ptr = buf.buf;
      stringbuf_cat_locale_string (&buf, dir);

      /* Concatenate the path name and the filename. */

#ifdef __MINGW32__
      if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/') && (buf.ptr[-1] != '\\'))
#else
      if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/'))
#endif
	stringbuf_cat (&buf, "/");

      stringbuf_cat (&buf, filename_chars);
      sans_ext_len = buf.ptr - buf.buf;

      /* Try every extension. */
      for (exts = extensions; scm_is_pair (exts); exts = SCM_CDR (exts))
	{
	  SCM ext = SCM_CAR (exts);
	  struct stat mode;

	  buf.ptr = buf.buf + sans_ext_len;
	  stringbuf_cat_locale_string (&buf, ext);

	  /* If the file exists at all, we should return it.  If the
	     file is inaccessible, then that's an error.  */

	  if (stat (buf.buf, &mode) == 0
	      && ! (mode.st_mode & S_IFDIR))
	    {
	      result = scm_from_locale_string (buf.buf);
	      goto end;
	    }
	}

      if (!SCM_NULL_OR_NIL_P (exts))
	scm_wrong_type_arg_msg (NULL, 0, extensions, "proper list");
    }

  if (!SCM_NULL_OR_NIL_P (path))
    scm_wrong_type_arg_msg (NULL, 0, path, "proper list");

 end:
  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

/* Search %load-path for a directory containing a file named FILENAME.
   The file must be readable, and not a directory.
   If we find one, return its full filename; otherwise, return #f.
   If FILENAME is absolute, return it unchanged.  */
SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
	    (SCM filename),
	    "Search @var{%load-path} for the file named @var{filename},\n"
	    "which must be readable by the current user.  If @var{filename}\n"
	    "is found in the list of paths to search or is an absolute\n"
	    "pathname, return its full pathname.  Otherwise, return\n"
	    "@code{#f}.  Filenames may have any of the optional extensions\n"
	    "in the @code{%load-extensions} list; @code{%search-load-path}\n"
	    "will try each extension automatically.")
#define FUNC_NAME s_scm_sys_search_load_path
{
  SCM path = *scm_loc_load_path;
  SCM exts = *scm_loc_load_extensions;
  SCM_VALIDATE_STRING (1, filename);

  if (scm_ilength (path) < 0)
    SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL);
  if (scm_ilength (exts) < 0)
    SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL);
  return scm_search_path (path, filename, exts);
}
#undef FUNC_NAME

SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0,
	    (SCM filename),
	    "Search @var{%load-path} for the file named @var{filename} and\n"
	    "load it into the top-level environment.  If @var{filename} is a\n"
	    "relative pathname and is not found in the list of search paths,\n"
	    "an error is signalled.")
#define FUNC_NAME s_scm_primitive_load_path
{
  SCM full_filename;

  full_filename = scm_sys_search_load_path (filename);

  if (scm_is_false (full_filename))
    SCM_MISC_ERROR ("Unable to find file ~S in load path",
		    scm_list_1 (filename));

  return scm_primitive_load (full_filename);
}
#undef FUNC_NAME

SCM
scm_c_primitive_load_path (const char *filename)
{
  return scm_primitive_load_path (scm_from_locale_string (filename));
}

/* Information about the build environment.  */

/* Initialize the scheme variable %guile-build-info, based on data
   provided by the Makefile, via libpath.h.  */
static void
init_build_info ()
{
  static struct { char *name; char *value; } info[] = SCM_BUILD_INFO;
  SCM *loc = SCM_VARIABLE_LOC (scm_c_define ("%guile-build-info", SCM_EOL));
  unsigned long i;

  for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++)
    {
      SCM key = scm_from_locale_symbol (info[i].name);
      SCM val = scm_from_locale_string (info[i].value);
      *loc = scm_acons (key, val, *loc);
    }
}

void
scm_init_load ()
{
  scm_listofnullstr = scm_permanent_object (scm_list_1 (scm_nullstr));
  scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL));
  scm_loc_load_extensions
    = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions",
				      scm_list_2 (scm_from_locale_string (".scm"),
						  scm_nullstr)));
  scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F));

  the_reader = scm_make_fluid ();
  the_reader_fluid_num = SCM_FLUID_NUM (the_reader);
  SCM_FAST_FLUID_SET_X (the_reader_fluid_num, SCM_BOOL_F);
  scm_c_define("current-reader", the_reader);

  init_build_info ();

#include "libguile/load.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_LOAD_H
#define SCM_LOAD_H

/* Copyright (C) 1995,1996,1998,2000,2001, 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_parse_path (SCM path, SCM tail);
SCM_API void scm_init_load_path (void);
SCM_API SCM scm_primitive_load (SCM filename);
SCM_API SCM scm_c_primitive_load (const char *filename);
SCM_API SCM scm_sys_package_data_dir (void);
SCM_API SCM scm_sys_library_dir (void);
SCM_API SCM scm_sys_site_dir (void);
SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts);
SCM_API SCM scm_sys_search_load_path (SCM filename);
SCM_API SCM scm_primitive_load_path (SCM filename);
SCM_API SCM scm_c_primitive_load_path (const char *filename);
SCM_API void scm_init_load (void);

#endif  /* SCM_LOAD_H */

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

license: unknown


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 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 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 "libguile/_scm.h"
#include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */
#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/print.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/deprecation.h"

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

scm_t_bits scm_tc16_macro;

static int
macro_print (SCM macro, SCM port, scm_print_state *pstate)
{
  SCM code = SCM_MACRO_CODE (macro);
  if (!SCM_CLOSUREP (code)
      || scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
      || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
					macro, port, pstate)))
    {
      if (!SCM_CLOSUREP (code))
	scm_puts ("#<primitive-", port);
      else
	scm_puts ("#<", port);

      if (SCM_MACRO_TYPE (macro) == 0)
	scm_puts ("syntax", port);
#if SCM_ENABLE_DEPRECATED == 1
      if (SCM_MACRO_TYPE (macro) == 1)
	scm_puts ("macro", port);
#endif
      if (SCM_MACRO_TYPE (macro) == 2)
	scm_puts ("macro!", port);
      if (SCM_MACRO_TYPE (macro) == 3)
	scm_puts ("builtin-macro!", port);

      scm_putc (' ', port);
      scm_iprin1 (scm_macro_name (macro), port, pstate);

      if (SCM_CLOSUREP (code) && SCM_PRINT_SOURCE_P)
	{
	  SCM formals = SCM_CLOSURE_FORMALS (code);
	  SCM env = SCM_ENV (code);
	  SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
	  SCM src = scm_i_unmemocopy_body (SCM_CODE (code), xenv);
	  scm_putc (' ', port);
	  scm_iprin1 (src, port, pstate);
	}

      scm_putc ('>', port);
    }

  return 1;
}

static SCM
makmac (SCM code, scm_t_bits flags)
{
  SCM z;
  SCM_NEWSMOB (z, scm_tc16_macro, SCM_UNPACK (code));
  SCM_SET_SMOB_FLAGS (z, flags);
  return z;
}

/* Return a mmacro that is known to be one of guile's built in macros. */
SCM
scm_i_makbimacro (SCM code)
#define FUNC_NAME "scm_i_makbimacro"
{
  SCM_VALIDATE_PROC (1, code);
  return makmac (code, 3);
}
#undef FUNC_NAME

SCM_DEFINE (scm_makmmacro, "procedure->memoizing-macro", 1, 0, 0,
           (SCM code),
	    "Return a @dfn{macro} which, when a symbol defined to this value\n"
	    "appears as the first symbol in an expression, evaluates the\n"
	    "result of applying @var{code} to the expression and the\n"
	    "environment.\n\n"
	    "@code{procedure->memoizing-macro} is the same as\n"
	    "@code{procedure->macro}, except that the expression returned by\n"
	    "@var{code} replaces the original macro expression in the memoized\n"
	    "form of the containing code.")
#define FUNC_NAME s_scm_makmmacro
{
  SCM_VALIDATE_PROC (1, code);
  return makmac (code, 2);
}
#undef FUNC_NAME

SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0,
            (SCM code),
	    "Return a @dfn{macro} which, when a symbol defined to this value\n"
	    "appears as the first symbol in an expression, returns the\n"
	    "result of applying @var{code} to the expression and the\n"
	    "environment.")
#define FUNC_NAME s_scm_makacro
{
  SCM_VALIDATE_PROC (1, code);
  return makmac (code, 0);
}
#undef FUNC_NAME

#if SCM_ENABLE_DEPRECATED == 1

SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0,
           (SCM code),
	    "Return a @dfn{macro} which, when a symbol defined to this value\n"
	    "appears as the first symbol in an expression, evaluates the\n"
	    "result of applying @var{code} to the expression and the\n"
	    "environment.  For example:\n"
	    "\n"
	    "@lisp\n"
	    "(define trace\n"
	    "  (procedure->macro\n"
	    "   (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n"
	    "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n"
	    "@end lisp")
#define FUNC_NAME s_scm_makmacro
{
  scm_c_issue_deprecation_warning
    ("The function procedure->macro is deprecated, and so are"
     " non-memoizing macros in general.  Use memoizing macros"
     " or r5rs macros instead.");

  SCM_VALIDATE_PROC (1, code);
  return makmac (code, 1);
}
#undef FUNC_NAME

#endif

SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a\n"
	    "syntax transformer.")
#define FUNC_NAME s_scm_macro_p
{
  return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj));
}
#undef FUNC_NAME

SCM_SYMBOL (scm_sym_syntax, "syntax");
#if SCM_ENABLE_DEPRECATED == 1
SCM_SYMBOL (scm_sym_macro, "macro");
#endif
SCM_SYMBOL (scm_sym_mmacro, "macro!");
SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!");

SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
            (SCM m),
	    "Return one of the symbols @code{syntax}, @code{macro} or\n"
	    "@code{macro!}, depending on whether @var{m} is a syntax\n"
	    "transformer, a regular macro, or a memoizing macro,\n"
	    "respectively.  If @var{m} is not a macro, @code{#f} is\n"
	    "returned.")
#define FUNC_NAME s_scm_macro_type
{
  if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m))
    return SCM_BOOL_F;
  switch (SCM_MACRO_TYPE (m))
    {
    case 0: return scm_sym_syntax;
#if SCM_ENABLE_DEPRECATED == 1
    case 1: return scm_sym_macro;
#endif
    case 2: return scm_sym_mmacro;
    case 3: return scm_sym_bimacro;
    default: scm_wrong_type_arg (FUNC_NAME, 1, m);
    }
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
            (SCM m),
	    "Return the name of the macro @var{m}.")
#define FUNC_NAME s_scm_macro_name
{
  SCM_VALIDATE_SMOB (1, m, macro);
  return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
            (SCM m),
	    "Return the transformer of the macro @var{m}.")
#define FUNC_NAME s_scm_macro_transformer
{
  SCM_VALIDATE_SMOB (1, m, macro);
  return ((SCM_CLOSUREP (SCM_PACK (SCM_SMOB_DATA (m)))) ?
	  SCM_PACK(SCM_SMOB_DATA (m)) : SCM_BOOL_F);
}
#undef FUNC_NAME

SCM
scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
{
  SCM var = scm_c_define (name, SCM_UNDEFINED);
  SCM transformer = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
  SCM_VARIABLE_SET (var, macroizer (transformer));
  return SCM_UNSPECIFIED;
}

void
scm_init_macros ()
{
  scm_tc16_macro = scm_make_smob_type ("macro", 0);
  scm_set_smob_mark (scm_tc16_macro, scm_markcdr);
  scm_set_smob_print (scm_tc16_macro, macro_print);
#include "libguile/macros.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_MACROS_H
#define SCM_MACROS_H

/* Copyright (C) 1998,2000,2001,2002,2003, 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"

#define SCM_ASSYNT(_cond, _msg, _subr) \
  if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL);

#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
#define SCM_MACRO_TYPE(m) SCM_SMOB_FLAGS (m)
#define SCM_BUILTIN_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 3)
#define SCM_MACRO_CODE(m) SCM_SMOB_OBJECT (m)

SCM_API scm_t_bits scm_tc16_macro;

SCM_API SCM scm_i_makbimacro (SCM code);
SCM_API SCM scm_makmmacro (SCM code);
SCM_API SCM scm_makacro (SCM code);
SCM_API SCM scm_macro_p (SCM obj);
SCM_API SCM scm_macro_type (SCM m);
SCM_API SCM scm_macro_name (SCM m);
SCM_API SCM scm_macro_transformer (SCM m);
SCM_API SCM scm_make_synt (const char *name,
			   SCM (*macroizer) (SCM),
			   SCM (*fcn) ());
SCM_API void scm_init_macros (void);

#if SCM_ENABLE_DEPRECATED == 1
SCM_API SCM scm_makmacro (SCM code);
#endif

#endif  /* SCM_MACROS_H */

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


code:
/* classes: src_files
 * Copyright (C) 1995,1997,1998,2000,2001, 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 "libguile/_scm.h"
#include "libguile/ports.h"
#include "libguile/smob.h"

#include "libguile/mallocs.h"

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

scm_t_bits scm_tc16_malloc;

static size_t
malloc_free (SCM ptr)
{
  if (SCM_MALLOCDATA (ptr))
    free (SCM_MALLOCDATA (ptr));
  return 0;
}

static int
malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_puts("#<malloc ", port);
  scm_uintprint (SCM_SMOB_DATA (exp), 16, port);
  scm_putc('>', port);
  return 1;
}

SCM
scm_malloc_obj (size_t n)
{
  scm_t_bits mem = n ? (scm_t_bits) scm_gc_malloc (n, "malloc smob") : 0;
  if (n && !mem)
    return SCM_BOOL_F;
  SCM_RETURN_NEWSMOB (scm_tc16_malloc, mem);
}

void
scm_init_mallocs ()
{
  scm_tc16_malloc = scm_make_smob_type ("malloc", 0);
  scm_set_smob_free (scm_tc16_malloc, malloc_free);
  scm_set_smob_print (scm_tc16_malloc, malloc_print);
}

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


code:
/* classes: h_files */

#ifndef SCM_MALLOCS_H
#define SCM_MALLOCS_H

/* Copyright (C) 1995,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_t_bits scm_tc16_malloc;

#define SCM_MALLOCP(X)  (SCM_SMOB_PREDICATE (scm_tc16_malloc, (X)))
#define SCM_MALLOCDATA(obj) ((char *) SCM_SMOB_DATA (obj))
#define SCM_SETMALLOCDATA(obj, val) (SCM_SET_SMOB_DATA ((obj), (val)))

SCM_API SCM scm_malloc_obj (size_t n);
SCM_API void scm_init_mallocs (void);

#endif  /* SCM_MALLOCS_H */

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


code:
;;;; Copyright (C) 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
;;;;

;;; Commentary:

;;; This code is run during the Guile build, in order to set the stack
;;; limit to a value that will allow the `make check' tests to pass,
;;; taking into account the average stack usage on the build platform.
;;; For more detail, see the text below that gets written out to the
;;; stack limit calibration file.

;;; Code:

;; Store off Guile's default stack limit.
(define default-stack-limit (cadr (memq 'stack (debug-options))))

;; Now disable the stack limit, so that we don't get a stack overflow
;; while running this code!
(debug-set! stack 0)

;; Define a variable to hold the measured stack high water mark (HWM).
(define top-repl-hwm-measured 0)

;; Use an evaluator trap to measure the stack size at every
;; evaluation step, and increase top-repl-hwm-measured if it is less
;; than the measured stack size.
(trap-set! enter-frame-handler
	   (lambda _
	     (let ((stack-size (%get-stack-size)))
	       (if (< top-repl-hwm-measured stack-size)
		   (set! top-repl-hwm-measured stack-size)))))
(trap-enable 'enter-frame)
(trap-enable 'traps)

;; Call (turn-on-debugging) and (top-repl) in order to simulate as
;; closely as possible what happens - and in particular, how much
;; stack is used - when a standard Guile REPL is started up.
;;
;; `make check' stack overflow errors have been reported in the past
;; for:
;;
;; - test-suite/standalone/test-use-srfi, which runs `guile -q
;;   --use-srfi=...' a few times, with standard input for the REPL
;;   coming from a shell script
;;
;; - test-suite/tests/elisp.test, which does not involve the REPL, but
;;   has a lot of `use-modules' calls.
;;
;; Stack high water mark (HWM) measurements show that the HWM is
;; higher in the test-use-srfi case - specifically because of the
;; complexity of (top-repl) - so that is what we simulate for our
;; calibration model here.
(turn-on-debugging)
(with-output-to-port (%make-void-port "w")
  (lambda ()
    (with-input-from-string "\n" top-repl)))

;; top-repl-hwm-measured now contains the stack HWM that resulted from
;; running that code.

;; This is the value of top-repl-hwm-measured that we get on a
;; `canonical' build platform.  (See text below for what that means.)
(define top-repl-hwm-i686-pc-linux-gnu 9461)

;; Using the above results, output code that tests can run in order to
;; configure the stack limit correctly for the current build platform.
(format #t "\
;; Stack limit calibration file.
;;
;; This file is automatically generated by Guile when it builds, in
;; order to set the stack limit to a value that reflects the stack
;; usage of the build platform (OS + compiler + compilation options),
;; specifically so that none of Guile's own tests (which are run by
;; `make check') fail because of a benign stack overflow condition.
;;
;; By a `benign' stack overflow condition, we mean one where the test
;; code is behaving correctly, but exceeds the configured stack limit
;; because the limit is set too low.  A non-benign stack overflow
;; condition would be if a piece of test code behaved significantly
;; differently on some platform to how it does normally, and as a
;; result consumed a lot more stack.  Although they seem pretty
;; unlikely, we would want to catch non-benign conditions like this,
;; and that is why we don't just do `(debug-set! stack 0)' when
;; running `make check'.
;;
;; Although the primary purpose of this file is to prevent `make
;; check' from failing without good reason, Guile developers and users
;; may also find the following information useful, when determining
;; what stack limit to configure for their own programs.

 (let (;; The stack high water mark measured when starting up the
       ;; standard Guile REPL on the current build platform.
       (top-repl-hwm-measured ~a)

       ;; The value of top-repl-hwm-measured that we get when building
       ;; Guile on an i686 PC GNU/Linux system, after configuring with
       ;; `./configure --enable-maintainer-mode --with-threads'.
       ;; (Hereafter referred to as the `canonical' build platform.)
       (top-repl-hwm-i686-pc-linux-gnu ~a)

       ;; Guile's default stack limit (i.e. the initial, C-coded value
       ;; of the 'stack debug option).  In the context of this file,
       ;; the important thing about this number is that we know that
       ;; it allows all of the `make check' tests to pass on the
       ;; canonical build platform.
       (default-stack-limit ~a)

       ;; Calibrated stack limit.  This is the default stack limit,
       ;; scaled by the factor between top-repl-hwm-i686-pc-linux-gnu
       ;; and top-repl-hwm-measured.
       (calibrated-stack-limit ~a))

   ;; Configure the calibrated stack limit.
   (debug-set! stack calibrated-stack-limit))
"
	top-repl-hwm-measured
	top-repl-hwm-i686-pc-linux-gnu
	default-stack-limit
	;; Use quotient here to get an integer result, rather than a
	;; rational.
	(quotient (* default-stack-limit top-repl-hwm-measured)
		  top-repl-hwm-i686-pc-linux-gnu))


code:
/* Wrapper to implement ANSI C's memmove using BSD's bcopy. */
/* This function is in the public domain.  --Per Bothner. */

#include <sys/types.h>

#ifdef __STDC__
#define PTR void *
#define CPTR const void *
PTR memmove (PTR, CPTR, size_t);
#else
#define PTR char *
#define CPTR char *
PTR memmove ();
#endif

PTR
memmove (PTR s1, CPTR s2, size_t n)
{
  bcopy (s2, s1, n);
  return s1;
}

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


code:
/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006 Free Software Foundation, Inc.
   This file is derived from mkstemps.c from the GNU Libiberty Library
   which in turn is derived from the GNU C Library.

   The GNU C Library is free software; you can redistribute it and/or
   modify it under the terms of the GNU Library General Public License as
   published by the Free Software Foundation; either version 2 of the
   License, or (at your option) any later version.

   The GNU C 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
   Library General Public License for more details.

   You should have received a copy of the GNU Library General Public
   License along with the GNU C Library; see the file COPYING.LIB.  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 "libguile/__scm.h"

#ifdef HAVE_STDLIB_H
#include <stdlib.h>
#endif
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#include <errno.h>
#include <stdio.h>
#include <fcntl.h>
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif
#ifdef __MINGW32__
#include <process.h>
#endif

#ifndef TMP_MAX
#define TMP_MAX 16384
#endif

/* We provide this prototype to avoid compiler warnings.  If this ever
   conflicts with a declaration in a system header file, we'll find
   out, because we should include that header file here.  */
int mkstemp (char *);

/* Generate a unique temporary file name from TEMPLATE.

   TEMPLATE has the form:

   <path>/ccXXXXXX

   The last six characters of TEMPLATE must be "XXXXXX"; they are
   replaced with a string that makes the filename unique.

   Returns a file descriptor open on the file for reading and writing.  */
int
mkstemp (template)
     char *template;
{
  static const char letters[]
    = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";
  static scm_t_uint64 value;
#ifdef HAVE_GETTIMEOFDAY
  struct timeval tv;
#endif
  char *XXXXXX;
  size_t len;
  int count;

  len = strlen (template);

  if ((int) len < 6
      || strncmp (&template[len - 6], "XXXXXX", 6))
    {
      return -1;
    }

  XXXXXX = &template[len - 6];

#ifdef HAVE_GETTIMEOFDAY
  /* Get some more or less random data.  */
  gettimeofday (&tv, NULL);
  value += ((scm_t_uint64) tv.tv_usec << 16) ^ tv.tv_sec ^ getpid ();
#else
  value += getpid ();
#endif

  for (count = 0; count < TMP_MAX; ++count)
    {
      scm_t_uint64 v = value;
      int fd;

      /* Fill in the random bits.  */
      XXXXXX[0] = letters[v % 62];
      v /= 62;
      XXXXXX[1] = letters[v % 62];
      v /= 62;
      XXXXXX[2] = letters[v % 62];
      v /= 62;
      XXXXXX[3] = letters[v % 62];
      v /= 62;
      XXXXXX[4] = letters[v % 62];
      v /= 62;
      XXXXXX[5] = letters[v % 62];

      fd = open (template, O_RDWR|O_CREAT|O_EXCL, 0600);
      if (fd >= 0)
	/* The file does not exist.  */
	return fd;

      /* This is a random value.  It is only necessary that the next
	 TMP_MAX values generated by adding 7777 to VALUE are different
	 with (module 2^32).  */
      value += 7777;
    }

  /* We return the null string if we can't find a unique file name.  */
  template[0] = '\0';
  return -1;
}


code:
/* Copyright (C) 1998,2000,2001,2002, 2003, 2004, 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 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 <stdarg.h>

#include "libguile/_scm.h"

#include "libguile/eval.h"
#include "libguile/smob.h"
#include "libguile/procprop.h"
#include "libguile/vectors.h"
#include "libguile/hashtab.h"
#include "libguile/struct.h"
#include "libguile/variable.h"
#include "libguile/fluids.h"
#include "libguile/deprecation.h"

#include "libguile/modules.h"

int scm_module_system_booted_p = 0;

scm_t_bits scm_module_tag;

static SCM the_module;

static SCM the_root_module_var;

static SCM
the_root_module ()
{
  if (scm_module_system_booted_p)
    return SCM_VARIABLE_REF (the_root_module_var);
  else
    return SCM_BOOL_F;
}

SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
	    (),
	    "Return the current module.")
#define FUNC_NAME s_scm_current_module
{
  SCM curr = scm_fluid_ref (the_module);

  return scm_is_true (curr) ? curr : the_root_module ();
}
#undef FUNC_NAME

static void scm_post_boot_init_modules (void);

SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
	    (SCM module),
	    "Set the current module to @var{module} and return\n"
	    "the previous current module.")
#define FUNC_NAME s_scm_set_current_module
{
  SCM old;

  if (!scm_module_system_booted_p)
    scm_post_boot_init_modules ();

  SCM_VALIDATE_MODULE (SCM_ARG1, module);

  old = scm_current_module ();
  scm_fluid_set_x (the_module, module);

  return old;
}
#undef FUNC_NAME

SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
	    (),
	    "Return a specifier for the environment that contains\n"
	    "implementation--defined bindings, typically a superset of those\n"
	    "listed in the report.  The intent is that this procedure will\n"
	    "return the environment in which the implementation would\n"
	    "evaluate expressions dynamically typed by the user.")
#define FUNC_NAME s_scm_interaction_environment
{
  return scm_current_module ();
}
#undef FUNC_NAME

SCM
scm_c_call_with_current_module (SCM module,
				SCM (*func)(void *), void *data)
{
  return scm_c_with_fluid (the_module, module, func, data);
}

void
scm_dynwind_current_module (SCM module)
{
  scm_dynwind_fluid (the_module, module);
}

/*
  convert "A B C" to scheme list (A B C)
 */
static SCM
convert_module_name (const char *name)
{
  SCM list = SCM_EOL;
  SCM *tail = &list;

  const char *ptr;
  while (*name)
    {
      while (*name == ' ')
	name++;
      ptr = name;
      while (*ptr && *ptr != ' ')
	ptr++;
      if (ptr > name)
	{
	  SCM sym = scm_from_locale_symboln (name, ptr-name);
	  *tail = scm_cons (sym, SCM_EOL);
	  tail = SCM_CDRLOC (*tail);
	}
      name = ptr;
    }

  return list;
}

static SCM process_define_module_var;
static SCM process_use_modules_var;
static SCM resolve_module_var;

SCM
scm_c_resolve_module (const char *name)
{
  return scm_resolve_module (convert_module_name (name));
}

SCM
scm_resolve_module (SCM name)
{
  return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name);
}

SCM
scm_c_define_module (const char *name,
		     void (*init)(void *), void *data)
{
  SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var),
			   scm_list_1 (convert_module_name (name)));
  if (init)
    scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
  return module;
}

void
scm_c_use_module (const char *name)
{
  scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var),
	      scm_list_1 (scm_list_1 (convert_module_name (name))));
}

static SCM module_export_x_var;

/*
  TODO: should export this function? --hwn.
 */
static SCM
scm_export (SCM module, SCM namelist)
{
  return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
		     module, namelist);
}

/*
  @code{scm_c_export}(@var{name-list})

  @code{scm_c_export} exports the named bindings from the current
  module, making them visible to users of the module. This function
  takes a list of string arguments, terminated by NULL, e.g.

  @example
    scm_c_export ("add-double-record", "bamboozle-money", NULL);
  @end example
*/
void
scm_c_export (const char *name, ...)
{
  if (name)
    {
      va_list ap;
      SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
      SCM *tail = SCM_CDRLOC (names);
      va_start (ap, name);
      while (1)
	{
	  const char *n = va_arg (ap, const char *);
	  if (n == NULL)
	    break;
	  *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
	  tail = SCM_CDRLOC (*tail);
	}
      va_end (ap);
      scm_export (scm_current_module(), names);
    }
}

/* Environments */

SCM
scm_top_level_env (SCM thunk)
{
  if (SCM_IMP (thunk))
    return SCM_EOL;
  else
    return scm_cons (thunk, SCM_EOL);
}

SCM
scm_env_top_level (SCM env)
{
  while (scm_is_pair (env))
    {
      SCM car_env = SCM_CAR (env);
      if (!scm_is_pair (car_env) && scm_is_true (scm_procedure_p (car_env)))
	return car_env;
      env = SCM_CDR (env);
    }
  return SCM_BOOL_F;
}

SCM_SYMBOL (sym_module, "module");

SCM
scm_lookup_closure_module (SCM proc)
{
  if (scm_is_false (proc))
    return the_root_module ();
  else if (SCM_EVAL_CLOSURE_P (proc))
    return SCM_PACK (SCM_SMOB_DATA (proc));
  else
    {
      SCM mod = scm_procedure_property (proc, sym_module);
      if (scm_is_false (mod))
	mod = the_root_module ();
      return mod;
    }
}

SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
	    (SCM env),
	    "Return the module of @var{ENV}, a lexical environment.")
#define FUNC_NAME s_scm_env_module
{
  return scm_lookup_closure_module (scm_env_top_level (env));
}
#undef FUNC_NAME

/*
 * C level implementation of the standard eval closure
 *
 * This increases loading speed substantially.
 * The code will be replaced by the low-level environments in next release.
 */

static SCM module_make_local_var_x_var;

static SCM
module_variable (SCM module, SCM sym)
{
#define SCM_BOUND_THING_P(b) \
  (scm_is_true (b))

  /* 1. Check module obarray */
  SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
  if (SCM_BOUND_THING_P (b))
    return b;
  {
    SCM binder = SCM_MODULE_BINDER (module);
    if (scm_is_true (binder))
      /* 2. Custom binder */
      {
	b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
	if (SCM_BOUND_THING_P (b))
	  return b;
      }
  }
  {
    /* 3. Search the use list */
    SCM uses = SCM_MODULE_USES (module);
    while (scm_is_pair (uses))
      {
	b = module_variable (SCM_CAR (uses), sym);
	if (SCM_BOUND_THING_P (b))
	  return b;
	uses = SCM_CDR (uses);
      }
    return SCM_BOOL_F;
  }
#undef SCM_BOUND_THING_P
}

scm_t_bits scm_tc16_eval_closure;

#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
  (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)

/* NOTE: This function may be called by a smob application
   or from another C function directly. */
SCM
scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
{
  SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
  if (scm_is_true (definep))
    {
      if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
	return SCM_BOOL_F;
      return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
			 module, sym);
    }
  else
    return module_variable (module, sym);
}

SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
	    (SCM module),
	    "Return an eval closure for the module @var{module}.")
#define FUNC_NAME s_scm_standard_eval_closure
{
  SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
}
#undef FUNC_NAME

SCM_DEFINE (scm_standard_interface_eval_closure,
	    "standard-interface-eval-closure", 1, 0, 0,
	    (SCM module),
	    "Return a interface eval closure for the module @var{module}. "
	    "Such a closure does not allow new bindings to be added.")
#define FUNC_NAME s_scm_standard_interface_eval_closure
{
  SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
		      SCM_UNPACK (module));
}
#undef FUNC_NAME

SCM
scm_module_lookup_closure (SCM module)
{
  if (scm_is_false (module))
    return SCM_BOOL_F;
  else
    return SCM_MODULE_EVAL_CLOSURE (module);
}

SCM
scm_current_module_lookup_closure ()
{
  if (scm_module_system_booted_p)
    return scm_module_lookup_closure (scm_current_module ());
  else
    return SCM_BOOL_F;
}

SCM
scm_module_transformer (SCM module)
{
  if (scm_is_false (module))
    return SCM_BOOL_F;
  else
    return SCM_MODULE_TRANSFORMER (module);
}

SCM
scm_current_module_transformer ()
{
  if (scm_module_system_booted_p)
    return scm_module_transformer (scm_current_module ());
  else
    return SCM_BOOL_F;
}

SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
	    (SCM module, SCM sym),
	    "")
#define FUNC_NAME s_scm_module_import_interface
{
#define SCM_BOUND_THING_P(b) (scm_is_true (b))
  SCM uses;
  SCM_VALIDATE_MODULE (SCM_ARG1, module);
  /* Search the use list */
  uses = SCM_MODULE_USES (module);
  while (scm_is_pair (uses))
    {
      SCM _interface = SCM_CAR (uses);
      /* 1. Check module obarray */
      SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
      if (SCM_BOUND_THING_P (b))
	return _interface;
      {
	SCM binder = SCM_MODULE_BINDER (_interface);
	if (scm_is_true (binder))
	  /* 2. Custom binder */
	  {
	    b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F);
	    if (SCM_BOUND_THING_P (b))
	      return _interface;
	  }
      }
      /* 3. Search use list recursively. */
      _interface = scm_module_import_interface (_interface, sym);
      if (scm_is_true (_interface))
	return _interface;
      uses = SCM_CDR (uses);
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

/* scm_sym2var
 *
 * looks up the variable bound to SYM according to PROC.  PROC should be
 * a `eval closure' of some module.
 *
 * When no binding exists, and DEFINEP is true, create a new binding
 * with a initial value of SCM_UNDEFINED.  Return `#f' when DEFINEP as
 * false and no binding exists.
 *
 * When PROC is `#f', it is ignored and the binding is searched for in
 * the scm_pre_modules_obarray (a `eq' hash table).
 */

SCM scm_pre_modules_obarray;

SCM
scm_sym2var (SCM sym, SCM proc, SCM definep)
#define FUNC_NAME "scm_sym2var"
{
  SCM var;

  if (SCM_NIMP (proc))
    {
      if (SCM_EVAL_CLOSURE_P (proc))
	{
	  /* Bypass evaluator in the standard case. */
	  var = scm_eval_closure_lookup (proc, sym, definep);
	}
      else
	var = scm_call_2 (proc, sym, definep);
    }
  else
    {
      SCM handle;

      if (scm_is_false (definep))
	var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
      else
	{
	  handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
					      sym, SCM_BOOL_F);
	  var = SCM_CDR (handle);
	  if (scm_is_false (var))
	    {
	      var = scm_make_variable (SCM_UNDEFINED);
	      SCM_SETCDR (handle, var);
	    }
	}
    }

  if (scm_is_true (var) && !SCM_VARIABLEP (var))
    SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));

  return var;
}
#undef FUNC_NAME

SCM
scm_c_module_lookup (SCM module, const char *name)
{
  return scm_module_lookup (module, scm_from_locale_symbol (name));
}

SCM
scm_module_lookup (SCM module, SCM sym)
#define FUNC_NAME "module-lookup"
{
  SCM var;
  SCM_VALIDATE_MODULE (1, module);

  var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
  if (scm_is_false (var))
    SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
  return var;
}
#undef FUNC_NAME

SCM
scm_c_lookup (const char *name)
{
  return scm_lookup (scm_from_locale_symbol (name));
}

SCM
scm_lookup (SCM sym)
{
  SCM var =
    scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
  if (scm_is_false (var))
    scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
  return var;
}

SCM
scm_c_module_define (SCM module, const char *name, SCM value)
{
  return scm_module_define (module, scm_from_locale_symbol (name), value);
}

SCM
scm_module_define (SCM module, SCM sym, SCM value)
#define FUNC_NAME "module-define"
{
  SCM var;
  SCM_VALIDATE_MODULE (1, module);

  var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
  SCM_VARIABLE_SET (var, value);
  return var;
}
#undef FUNC_NAME

SCM
scm_c_define (const char *name, SCM value)
{
  return scm_define (scm_from_locale_symbol (name), value);
}

SCM
scm_define (SCM sym, SCM value)
{
  SCM var =
    scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
  SCM_VARIABLE_SET (var, value);
  return var;
}

SCM
scm_module_reverse_lookup (SCM module, SCM variable)
#define FUNC_NAME "module-reverse-lookup"
{
  SCM obarray;
  long i, n;

  if (scm_is_false (module))
    obarray = scm_pre_modules_obarray;
  else
    {
      SCM_VALIDATE_MODULE (1, module);
      obarray = SCM_MODULE_OBARRAY (module);
    }

  if (!SCM_HASHTABLE_P (obarray))
      return SCM_BOOL_F;

  /* XXX - We do not use scm_hash_fold here to avoid searching the
     whole obarray.  We should have a scm_hash_find procedure. */

  n = SCM_HASHTABLE_N_BUCKETS (obarray);
  for (i = 0; i < n; ++i)
    {
      SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle;
      while (!scm_is_null (ls))
	{
	  handle = SCM_CAR (ls);
	  if (SCM_CDR (handle) == variable)
	    return SCM_CAR (handle);
	  ls = SCM_CDR (ls);
	}
    }

  /* Try the `uses' list.
   */
  {
    SCM uses = SCM_MODULE_USES (module);
    while (scm_is_pair (uses))
      {
	SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
	if (scm_is_true (sym))
	  return sym;
	uses = SCM_CDR (uses);
      }
  }

  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
	    (),
	    "Return the obarray that is used for all new bindings before "
	    "the module system is booted.  The first call to "
	    "@code{set-current-module} will boot the module system.")
#define FUNC_NAME s_scm_get_pre_modules_obarray
{
  return scm_pre_modules_obarray;
}
#undef FUNC_NAME

SCM_SYMBOL (scm_sym_system_module, "system-module");

SCM
scm_system_module_env_p (SCM env)
{
  SCM proc = scm_env_top_level (env);
  if (scm_is_false (proc))
    return SCM_BOOL_T;
  return ((scm_is_true (scm_procedure_property (proc,
						scm_sym_system_module)))
	  ? SCM_BOOL_T
	  : SCM_BOOL_F);
}

void
scm_modules_prehistory ()
{
  scm_pre_modules_obarray
    = scm_permanent_object (scm_c_make_hash_table (1533));
}

void
scm_init_modules ()
{
#include "libguile/modules.x"
  module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
					    SCM_UNDEFINED);
  scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
  scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
  scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);

  the_module = scm_permanent_object (scm_make_fluid ());
}

static void
scm_post_boot_init_modules ()
{
#define PERM(x) scm_permanent_object(x)

  SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
  scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);

  resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
  process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
  process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
  module_export_x_var = PERM (scm_c_lookup ("module-export!"));
  the_root_module_var = PERM (scm_c_lookup ("the-root-module"));

  scm_module_system_booted_p = 1;
}

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


code:
/* classes: h_files */

#ifndef SCM_MODULES_H
#define SCM_MODULES_H

/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 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/validate.h"

SCM_API int scm_module_system_booted_p;
SCM_API scm_t_bits scm_module_tag;

#define SCM_MODULEP(OBJ) \
  (!SCM_IMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag)

#define SCM_VALIDATE_MODULE(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, MODULEP, "module")

/* NOTE: Indexes of module fields are dependent upon the definition of
 *       module-type in boot-9.scm.
 */

#define scm_module_index_obarray	0
#define scm_module_index_uses		1
#define scm_module_index_binder		2
#define scm_module_index_eval_closure	3
#define scm_module_index_transformer	4

#define SCM_MODULE_OBARRAY(module) \
  SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_obarray])
#define SCM_MODULE_USES(module) \
  SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_uses])
#define SCM_MODULE_BINDER(module) \
  SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_binder])
#define SCM_MODULE_EVAL_CLOSURE(module) \
  SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure])
#define SCM_MODULE_TRANSFORMER(module) \
  SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_transformer])

SCM_API scm_t_bits scm_tc16_eval_closure;

#define SCM_EVAL_CLOSURE_P(x)	SCM_TYP16_PREDICATE (scm_tc16_eval_closure, x)

SCM_API SCM scm_current_module (void);
SCM_API SCM scm_interaction_environment (void);
SCM_API SCM scm_set_current_module (SCM module);

SCM_API SCM scm_c_call_with_current_module (SCM module,
					    SCM (*func)(void *), void *data);
SCM_API void scm_dynwind_current_module (SCM module);

SCM_API SCM scm_c_lookup (const char *name);
SCM_API SCM scm_c_define (const char *name, SCM val);
SCM_API SCM scm_lookup (SCM symbol);
SCM_API SCM scm_define (SCM symbol, SCM val);

SCM_API SCM scm_c_module_lookup (SCM module, const char *name);
SCM_API SCM scm_c_module_define (SCM module, const char *name, SCM val);
SCM_API SCM scm_module_lookup (SCM module, SCM symbol);
SCM_API SCM scm_module_define (SCM module, SCM symbol, SCM val);
SCM_API SCM scm_module_reverse_lookup (SCM module, SCM variable);

SCM_API SCM scm_c_resolve_module (const char *name);
SCM_API SCM scm_resolve_module (SCM name);
SCM_API SCM scm_c_define_module (const char *name,
				 void (*init)(void *), void *data);
SCM_API void scm_c_use_module (const char *name);
SCM_API void scm_c_export (const char *name, ...);

SCM_API SCM scm_sym2var (SCM sym, SCM thunk, SCM definep);

SCM_API SCM scm_module_import_interface (SCM module, SCM sym);
SCM_API SCM scm_module_lookup_closure (SCM module);
SCM_API SCM scm_module_transformer (SCM module);
SCM_API SCM scm_current_module_lookup_closure (void);
SCM_API SCM scm_current_module_transformer (void);
SCM_API SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep);
SCM_API SCM scm_standard_eval_closure (SCM module);
SCM_API SCM scm_standard_interface_eval_closure (SCM module);
SCM_API SCM scm_get_pre_modules_obarray (void);
SCM_API SCM scm_lookup_closure_module (SCM proc);

SCM_API SCM scm_env_top_level (SCM env);
SCM_API SCM scm_env_module (SCM env);
SCM_API SCM scm_top_level_env (SCM thunk);
SCM_API SCM scm_system_module_env_p (SCM env);

SCM_API void scm_modules_prehistory (void);
SCM_API void scm_init_modules (void);

#endif  /* SCM_MODULES_H */

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


code:
/* "net_db.c" network database support
 * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 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 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
 */

/* Written in 1994 by Aubrey Jaffer.
 * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
 * Rewritten by Gary Houston to be a closer interface to the C socket library.
 * Split into net_db.c and socket.c.
 */

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

#include <errno.h>

#include "libguile/_scm.h"
#include "libguile/feature.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/dynwind.h"

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

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

#include <sys/types.h>

#ifdef HAVE_WINSOCK2_H
#include <winsock2.h>
#else
#include <sys/socket.h>
#include <netdb.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#endif

#ifdef __MINGW32__
#include "win32-socket.h"
#endif

#if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__) && !defined (__CYGWIN__)
/* h_errno not found in netdb.h, maybe this will help.  */
extern int h_errno;
#endif

#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR	\
  && !defined __MINGW32__ && !defined __CYGWIN__
/* Some OSes, such as Tru64 5.1b, lack a declaration for hstrerror(3).  */
extern const char *hstrerror (int);
#endif

SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
SCM_SYMBOL (scm_try_again_key, "try-again");
SCM_SYMBOL (scm_no_recovery_key, "no-recovery");
SCM_SYMBOL (scm_no_data_key, "no-data");

static void scm_resolv_error (const char *subr, SCM bad_value)
{
#ifdef NETDB_INTERNAL
  if (h_errno == NETDB_INTERNAL)
    {
      /* errno supposedly contains a useful value.  */
      scm_syserror (subr);
    }
  else
#endif
    {
      SCM key;
      const char *errmsg;

      switch (h_errno)
	{
	case HOST_NOT_FOUND:
	  key = scm_host_not_found_key;
	  errmsg = "Unknown host";
	  break;
	case TRY_AGAIN:
	  key = scm_try_again_key;
	  errmsg = "Host name lookup failure";
	  break;
	case NO_RECOVERY:
	  key = scm_no_recovery_key;
	  errmsg = "Unknown server error";
	  break;
	case NO_DATA:
	  key = scm_no_data_key;
	  errmsg = "No address associated with name";
	  break;
	default:
	  scm_misc_error (subr, "Unknown resolver error", SCM_EOL);
	  errmsg = NULL;
	}

#ifdef HAVE_HSTRERROR
      errmsg = (const char *) hstrerror (h_errno);
#endif
      scm_error (key, subr, errmsg, SCM_BOOL_F, SCM_EOL);
    }
}

/* Should take an extra arg for address format (will be needed for IPv6).
   Should use reentrant facilities if available.
 */

SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
            (SCM host),
	    "@deffnx {Scheme Procedure} gethostbyname hostname\n"
	    "@deffnx {Scheme Procedure} gethostbyaddr address\n"
	    "Look up a host by name or address, returning a host object.  The\n"
	    "@code{gethost} procedure will accept either a string name or an integer\n"
	    "address; if given no arguments, it behaves like @code{gethostent} (see\n"
	    "below).  If a name or address is supplied but the address can not be\n"
	    "found, an error will be thrown to one of the keys:\n"
	    "@code{host-not-found}, @code{try-again}, @code{no-recovery} or\n"
	    "@code{no-data}, corresponding to the equivalent @code{h_error} values.\n"
	    "Unusual conditions may result in errors thrown to the\n"
	    "@code{system-error} or @code{misc_error} keys.")
#define FUNC_NAME s_scm_gethost
{
  SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
  SCM lst = SCM_EOL;
  struct hostent *entry;
  struct in_addr inad;
  char **argv;
  int i = 0;

  if (SCM_UNBNDP (host))
    {
#ifdef HAVE_GETHOSTENT
      entry = gethostent ();
#else
      entry = NULL;
#endif
      if (! entry)
	{
	  /* As far as I can tell, there's no good way to tell whether
             zero means an error or end-of-file.  The trick of
             clearing errno before calling gethostent and checking it
             afterwards doesn't cut it, because, on Linux, it seems to
             try to contact some other server (YP?) and fails, which
             is a benign failure.  */
	  return SCM_BOOL_F;
	}
    }
  else if (scm_is_string (host))
    {
      char *str = scm_to_locale_string (host);
      entry = gethostbyname (str);
      free (str);
    }
  else
    {
      inad.s_addr = htonl (scm_to_ulong (host));
      entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
    }

  if (!entry)
    scm_resolv_error (FUNC_NAME, host);

  SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->h_name));
  SCM_SIMPLE_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->h_aliases));
  SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_int (entry->h_addrtype));
  SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_int (entry->h_length));
  if (sizeof (struct in_addr) != entry->h_length)
    {
      SCM_SIMPLE_VECTOR_SET(result, 4, SCM_BOOL_F);
      return result;
    }
  for (argv = entry->h_addr_list; argv[i]; i++);
  while (i--)
    {
      inad = *(struct in_addr *) argv[i];
      lst = scm_cons (scm_from_ulong (ntohl (inad.s_addr)), lst);
    }
  SCM_SIMPLE_VECTOR_SET(result, 4, lst);
  return result;
}
#undef FUNC_NAME

/* In all subsequent getMUMBLE functions, when we're called with no
   arguments, we're supposed to traverse the tables entry by entry.
   However, there doesn't seem to be any documented way to distinguish
   between end-of-table and an error; in both cases the functions
   return zero.  Gotta love Unix.  For the time being, we clear errno,
   and if we get a zero and errno is set, we signal an error.  This
   doesn't seem quite right (what if errno gets set as part of healthy
   operation?), but it seems to work okay.  We'll see.  */

#if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0,
            (SCM net),
	    "@deffnx {Scheme Procedure} getnetbyname net-name\n"
	    "@deffnx {Scheme Procedure} getnetbyaddr net-number\n"
	    "Look up a network by name or net number in the network database.  The\n"
	    "@var{net-name} argument must be a string, and the @var{net-number}\n"
	    "argument must be an integer.  @code{getnet} will accept either type of\n"
	    "argument, behaving like @code{getnetent} (see below) if no arguments are\n"
	    "given.")
#define FUNC_NAME s_scm_getnet
{
  SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
  struct netent *entry;
  int eno;

  if (SCM_UNBNDP (net))
    {
      entry = getnetent ();
      if (! entry)
	{
	  /* There's no good way to tell whether zero means an error
             or end-of-file, so we always return #f.  See `gethost'
             for details. */
	  return SCM_BOOL_F;
	}
    }
  else if (scm_is_string (net))
    {
      char *str = scm_to_locale_string (net);
      entry = getnetbyname (str);
      eno = errno;
      free (str);
    }
  else
    {
      unsigned long netnum = scm_to_ulong (net);
      entry = getnetbyaddr (netnum, AF_INET);
      eno = errno;
    }

  if (!entry)
    SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), eno);

  SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->n_name));
  SCM_SIMPLE_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->n_aliases));
  SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_int (entry->n_addrtype));
  SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_ulong (entry->n_net));
  return result;
}
#undef FUNC_NAME
#endif

#if defined (HAVE_GETPROTOENT) || defined (__MINGW32__)
SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
            (SCM protocol),
	    "@deffnx {Scheme Procedure} getprotobyname name\n"
	    "@deffnx {Scheme Procedure} getprotobynumber number\n"
	    "Look up a network protocol by name or by number.  @code{getprotobyname}\n"
	    "takes a string argument, and @code{getprotobynumber} takes an integer\n"
	    "argument.  @code{getproto} will accept either type, behaving like\n"
	    "@code{getprotoent} (see below) if no arguments are supplied.")
#define FUNC_NAME s_scm_getproto
{
  SCM result = scm_c_make_vector (3, SCM_UNSPECIFIED);
  struct protoent *entry;
  int eno;

  if (SCM_UNBNDP (protocol))
    {
      entry = getprotoent ();
      if (! entry)
	{
	  /* There's no good way to tell whether zero means an error
             or end-of-file, so we always return #f.  See `gethost'
             for details. */
	  return SCM_BOOL_F;
	}
    }
  else if (scm_is_string (protocol))
    {
      char *str = scm_to_locale_string (protocol);
      entry = getprotobyname (str);
      eno = errno;
      free (str);
    }
  else
    {
      unsigned long protonum = scm_to_ulong (protocol);
      entry = getprotobynumber (protonum);
      eno = errno;
    }

  if (!entry)
    SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), eno);

  SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->p_name));
  SCM_SIMPLE_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->p_aliases));
  SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_int (entry->p_proto));
  return result;
}
#undef FUNC_NAME
#endif

#if defined (HAVE_GETSERVENT) || defined (__MINGW32__)
static SCM
scm_return_entry (struct servent *entry)
{
  SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);

  SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->s_name));
  SCM_SIMPLE_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->s_aliases));
  SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_uint16 (ntohs (entry->s_port)));
  SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_locale_string (entry->s_proto));
  return result;
}

SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0,
            (SCM name, SCM protocol),
	    "@deffnx {Scheme Procedure} getservbyname name protocol\n"
	    "@deffnx {Scheme Procedure} getservbyport port protocol\n"
	    "Look up a network service by name or by service number, and return a\n"
	    "network service object.  The @var{protocol} argument specifies the name\n"
	    "of the desired protocol; if the protocol found in the network service\n"
	    "database does not match this name, a system error is signalled.\n\n"
	    "The @code{getserv} procedure will take either a service name or number\n"
	    "as its first argument; if given no arguments, it behaves like\n"
	    "@code{getservent} (see below).")
#define FUNC_NAME s_scm_getserv
{
  struct servent *entry;
  char *protoname;
  int eno;

  if (SCM_UNBNDP (name))
    {
      entry = getservent ();
      if (!entry)
	{
	  /* There's no good way to tell whether zero means an error
             or end-of-file, so we always return #f.  See `gethost'
             for details. */
	  return SCM_BOOL_F;
	}
      return scm_return_entry (entry);
    }

  scm_dynwind_begin (0);

  protoname = scm_to_locale_string (protocol);
  scm_dynwind_free (protoname);

  if (scm_is_string (name))
    {
      char *str = scm_to_locale_string (name);
      entry = getservbyname (str, protoname);
      eno = errno;
      free (str);
    }
  else
    {
      entry = getservbyport (htons (scm_to_int (name)), protoname);
      eno = errno;
    }

  if (!entry)
    SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name), eno);

  scm_dynwind_end ();
  return scm_return_entry (entry);
}
#undef FUNC_NAME
#endif

#if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
SCM_DEFINE (scm_sethost, "sethost", 0, 1, 0,
            (SCM stayopen),
	    "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n"
	    "Otherwise it is equivalent to @code{sethostent stayopen}.")
#define FUNC_NAME s_scm_sethost
{
  if (SCM_UNBNDP (stayopen))
    endhostent ();
  else
    sethostent (scm_is_true (stayopen));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

#if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0,
            (SCM stayopen),
	    "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n"
	    "Otherwise it is equivalent to @code{setnetent stayopen}.")
#define FUNC_NAME s_scm_setnet
{
  if (SCM_UNBNDP (stayopen))
    endnetent ();
  else
    setnetent (scm_is_true (stayopen));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

#if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) || defined (__MINGW32__)
SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0,
            (SCM stayopen),
	    "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n"
	    "Otherwise it is equivalent to @code{setprotoent stayopen}.")
#define FUNC_NAME s_scm_setproto
{
  if (SCM_UNBNDP (stayopen))
    endprotoent ();
  else
    setprotoent (scm_is_true (stayopen));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

#if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) || defined (__MINGW32__)
SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
            (SCM stayopen),
	    "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n"
	    "Otherwise it is equivalent to @code{setservent stayopen}.")
#define FUNC_NAME s_scm_setserv
{
  if (SCM_UNBNDP (stayopen))
    endservent ();
  else
    setservent (scm_is_true (stayopen));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

void
scm_init_net_db ()
{
  scm_add_feature ("net-db");
#include "libguile/net_db.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_NET_DB_H
#define SCM_NET_DB_H

/* Copyright (C) 1995,2000,2001, 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_gethost (SCM host);
SCM_API SCM scm_getnet (SCM name);
SCM_API SCM scm_getproto (SCM name);
SCM_API SCM scm_getserv (SCM name, SCM proto);
SCM_API SCM scm_sethost (SCM arg);
SCM_API SCM scm_setnet (SCM arg);
SCM_API SCM scm_setproto (SCM arg);
SCM_API SCM scm_setserv (SCM arg);
SCM_API void scm_init_net_db (void);

#endif  /* SCM_NET_DB_H */

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


code:
/* Copyright (C) 2002, 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 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 <stdlib.h>
#include "libguile/_scm.h"

#if SCM_USE_NULL_THREADS

#include "libguile/null-threads.h"

static scm_i_pthread_key_t *all_keys = NULL;

static void
destroy_keys (void)
{
  scm_i_pthread_key_t *key;
  int again;

  do {
    again = 0;
    for (key = all_keys; key; key = key->next)
      if (key->value && key->destr_func)
	{
	  void *v = key->value;
	  key->value = NULL;
	  key->destr_func (v);
	  again = 1;
	}
  } while (again);
}

int
scm_i_pthread_key_create (scm_i_pthread_key_t *key,
			  void (*destr_func) (void *))
{
  if (all_keys == NULL)
    atexit (destroy_keys);

  key->next = all_keys;
  all_keys = key;
  key->value = NULL;
  key->destr_func = destr_func;

  return 0;
}

#endif /* SCM_USE_NULL_THREADS */

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


code:
/* classes: h_files */

#ifndef SCM_NULL_THREADS_H
#define SCM_NULL_THREADS_H

/* Copyright (C) 2005, 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
 */

/* The null-threads implementation.  We provide the subset of the
   standard pthread API that is used by Guile, but no new threads can
   be created.

   This file merely exits so that Guile can be compiled and run
   without using pthreads.  Improving performance via optimizations
   that are possible in a single-threaded program is not a primary
   goal.
*/

#include <errno.h>

/* Threads
*/
#define scm_i_pthread_t                     int
#define scm_i_pthread_self()                0
#define scm_i_pthread_create(t,a,f,d)       (*(t)=0, (void)(f), ENOSYS)
#define scm_i_pthread_detach(t)             do { } while (0)
#define scm_i_pthread_exit(v)               exit(0)
#define scm_i_sched_yield()                 0

/* Signals
 */
#define scm_i_pthread_sigmask               sigprocmask

/* Mutexes
 */
#define SCM_I_PTHREAD_MUTEX_INITIALIZER     0
#define scm_i_pthread_mutex_t               int
#define scm_i_pthread_mutex_init(m,a)       (*(m) = 0)
#define scm_i_pthread_mutex_destroy(m)      do { (void)(m); } while(0)
#define scm_i_pthread_mutex_trylock(m)      ((*(m))++)
#define scm_i_pthread_mutex_lock(m)         ((*(m))++)
#define scm_i_pthread_mutex_unlock(m)       ((*(m))--)
#define scm_i_pthread_mutexattr_recursive   0

/* Condition variables
 */
#define SCM_I_PTHREAD_COND_INITIALIZER      0
#define scm_i_pthread_cond_t                int
#define scm_i_pthread_cond_init(c,a)        (*(c) = 0)
#define scm_i_pthread_cond_destroy(c)       do { (void)(c); } while(0)
#define scm_i_pthread_cond_signal(c)        (*(c) = 1)
#define scm_i_pthread_cond_broadcast(c)     (*(c) = 1)
#define scm_i_pthread_cond_wait(c,m)        (abort(), 0)
#define scm_i_pthread_cond_timedwait(c,m,t) (abort(), 0)

/* Onces
 */
#define scm_i_pthread_once_t                int
#define SCM_I_PTHREAD_ONCE_INIT             0
#define scm_i_pthread_once(o,f)             do { \
                                              if(!*(o)) { *(o)=1; f (); } \
                                            } while(0)

/* Thread specific storage
 */
typedef struct scm_i_pthread_key_t {
  struct scm_i_pthread_key_t *next;
  void *value;
  void (*destr_func) (void *);
} scm_i_pthread_key_t;

SCM_API int scm_i_pthread_key_create (scm_i_pthread_key_t *key,
				      void (*destr_func) (void *));
#define scm_i_pthread_setspecific(k,p)      ((k).value = (p))
#define scm_i_pthread_getspecific(k)        ((k).value)

/* Convenience functions
 */
#define scm_i_scm_pthread_mutex_lock        scm_i_pthread_mutex_lock
#define scm_i_dynwind_pthread_mutex_lock    scm_i_pthread_mutex_lock
#define scm_i_scm_pthread_cond_wait         scm_i_pthread_cond_wait
#define scm_i_scm_pthread_cond_timedwait    scm_i_pthread_cond_timedwait

#endif  /* SCM_NULL_THREADS_H */

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