code:
/* 	Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 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 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/dynwind.h"
#include "libguile/feature.h"
#include "libguile/fports.h"
#include "libguile/hashtab.h"
#include "libguile/ioext.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/validate.h"

#include <fcntl.h>

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

SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0,
            (SCM fd_port),
	    "Return an integer representing the current position of\n"
	    "@var{fd/port}, measured from the beginning.  Equivalent to:\n"
	    "\n"
	    "@lisp\n"
	    "(seek port 0 SEEK_CUR)\n"
	    "@end lisp")
#define FUNC_NAME s_scm_ftell
{
  return scm_seek (fd_port, SCM_INUM0, scm_from_int (SEEK_CUR));
}
#undef FUNC_NAME

SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
            (SCM old, SCM new),
	    "This procedure takes two ports and duplicates the underlying file\n"
	    "descriptor from @var{old-port} into @var{new-port}.  The\n"
	    "current file descriptor in @var{new-port} will be closed.\n"
	    "After the redirection the two ports will share a file position\n"
	    "and file status flags.\n\n"
	    "The return value is unspecified.\n\n"
	    "Unexpected behaviour can result if both ports are subsequently used\n"
	    "and the original and/or duplicate ports are buffered.\n\n"
	    "This procedure does not have any side effects on other ports or\n"
	    "revealed counts.")
#define FUNC_NAME s_scm_redirect_port
{
  int ans, oldfd, newfd;
  scm_t_fport *fp;

  old = SCM_COERCE_OUTPORT (old);
  new = SCM_COERCE_OUTPORT (new);

  SCM_VALIDATE_OPFPORT (1, old);
  SCM_VALIDATE_OPFPORT (2, new);
  oldfd = SCM_FPORT_FDES (old);
  fp = SCM_FSTREAM (new);
  newfd = fp->fdes;
  if (oldfd != newfd)
    {
      scm_t_port *pt = SCM_PTAB_ENTRY (new);
      scm_t_port *old_pt = SCM_PTAB_ENTRY (old);
      scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];

      /* must flush to old fdes.  */
      if (pt->rw_active == SCM_PORT_WRITE)
	ptob->flush (new);
      else if (pt->rw_active == SCM_PORT_READ)
	scm_end_input (new);
      ans = dup2 (oldfd, newfd);
      if (ans == -1)
	SCM_SYSERROR;
      pt->rw_random = old_pt->rw_random;
      /* continue using existing buffers, even if inappropriate.  */
    }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
            (SCM fd_or_port, SCM fd),
	    "Return a new integer file descriptor referring to the open file\n"
	    "designated by @var{fd_or_port}, which must be either an open\n"
	    "file port or a file descriptor.")
#define FUNC_NAME s_scm_dup_to_fdes
{
  int oldfd, newfd, rv;

  fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);

  if (scm_is_integer (fd_or_port))
    oldfd = scm_to_int (fd_or_port);
  else
    {
      SCM_VALIDATE_OPFPORT (1, fd_or_port);
      oldfd = SCM_FPORT_FDES (fd_or_port);
    }

  if (SCM_UNBNDP (fd))
    {
      newfd = dup (oldfd);
      if (newfd == -1)
	SCM_SYSERROR;
      fd = scm_from_int (newfd);
    }
  else
    {
      newfd = scm_to_int (fd);
      if (oldfd != newfd)
	{
	  scm_evict_ports (newfd);	/* see scsh manual.  */
	  rv = dup2 (oldfd, newfd);
	  if (rv == -1)
	    SCM_SYSERROR;
	}
    }
  return fd;
}
#undef FUNC_NAME

SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0,
            (SCM oldfd, SCM newfd),
	    "A simple wrapper for the @code{dup2} system call.\n"
	    "Copies the file descriptor @var{oldfd} to descriptor\n"
	    "number @var{newfd}, replacing the previous meaning\n"
	    "of @var{newfd}.  Both @var{oldfd} and @var{newfd} must\n"
	    "be integers.\n"
	    "Unlike for dup->fdes or primitive-move->fdes, no attempt\n"
	    "is made to move away ports which are using @var{newfd}.\n"
	    "The return value is unspecified.")
#define FUNC_NAME s_scm_dup2
{
  int c_oldfd;
  int c_newfd;
  int rv;

  c_oldfd = scm_to_int (oldfd);
  c_newfd = scm_to_int (newfd);
  rv = dup2 (c_oldfd, c_newfd);
  if (rv == -1)
    SCM_SYSERROR;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0,
            (SCM port),
	    "Return the integer file descriptor underlying @var{port}.  Does\n"
	    "not change its revealed count.")
#define FUNC_NAME s_scm_fileno
{
  port = SCM_COERCE_OUTPORT (port);
  SCM_VALIDATE_OPFPORT (1, port);
  return scm_from_int (SCM_FPORT_FDES (port));
}
#undef FUNC_NAME

/* GJB:FIXME:: why does this not throw
   an error if the arg is not a port?
   This proc as is would be better names isattyport?
   if it is not going to assume that the arg is a port

   [cmm] I don't see any problem with the above.  why should a type
   predicate assume _anything_ about its argument?
*/
SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
            (SCM port),
	    "Return @code{#t} if @var{port} is using a serial non--file\n"
	    "device, otherwise @code{#f}.")
#define FUNC_NAME s_scm_isatty_p
{
  int rv;

  port = SCM_COERCE_OUTPORT (port);

  if (!SCM_OPFPORTP (port))
    return SCM_BOOL_F;

  rv = isatty (SCM_FPORT_FDES (port));
  return  scm_from_bool(rv);
}
#undef FUNC_NAME

SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0,
            (SCM fdes, SCM modes),
	    "Return a new port based on the file descriptor @var{fdes}.\n"
	    "Modes are given by the string @var{modes}.  The revealed count\n"
	    "of the port is initialized to zero.  The modes string is the\n"
	    "same as that accepted by @ref{File Ports, open-file}.")
#define FUNC_NAME s_scm_fdopen
{
  return scm_i_fdes_to_port (scm_to_int (fdes),
			     scm_i_mode_bits (modes), SCM_BOOL_F);
}
#undef FUNC_NAME

/* Move a port's underlying file descriptor to a given value.
 * Returns  #f if fdes is already the given value.
 *          #t if fdes moved.
 * MOVE->FDES is implemented in Scheme and calls this primitive.
 */
SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
            (SCM port, SCM fd),
	    "Moves the underlying file descriptor for @var{port} to the integer\n"
	    "value @var{fdes} without changing the revealed count of @var{port}.\n"
	    "Any other ports already using this descriptor will be automatically\n"
	    "shifted to new descriptors and their revealed counts reset to zero.\n"
	    "The return value is @code{#f} if the file descriptor already had the\n"
	    "required value or @code{#t} if it was moved.")
#define FUNC_NAME s_scm_primitive_move_to_fdes
{
  scm_t_fport *stream;
  int old_fd;
  int new_fd;
  int rv;

  port = SCM_COERCE_OUTPORT (port);

  SCM_VALIDATE_OPFPORT (1, port);
  stream = SCM_FSTREAM (port);
  old_fd = stream->fdes;
  new_fd = scm_to_int (fd);
  if  (old_fd == new_fd)
    {
      return SCM_BOOL_F;
    }
  scm_evict_ports (new_fd);
  rv = dup2 (old_fd, new_fd);
  if (rv == -1)
    SCM_SYSERROR;
  stream->fdes = new_fd;
  SCM_SYSCALL (close (old_fd));
  return SCM_BOOL_T;
}
#undef FUNC_NAME

static SCM
get_matching_port (void *closure, SCM port, SCM val, SCM result)
{
  int fd = * (int *) closure;
  scm_t_port *entry = SCM_PTAB_ENTRY (port);

  if (SCM_OPFPORTP (port)
      && ((scm_t_fport *) entry->stream)->fdes == fd)
    result = scm_cons (port, result);

  return result;
}

/* Return a list of ports using a given file descriptor.  */
SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
           (SCM fd),
	    "Return a list of existing ports which have @var{fdes} as an\n"
	    "underlying file descriptor, without changing their revealed\n"
	    "counts.")
#define FUNC_NAME s_scm_fdes_to_ports
{
  SCM result = SCM_EOL;
  int int_fd = scm_to_int (fd);

  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
  result = scm_internal_hash_fold (get_matching_port,
				   (void*) &int_fd, result,
				   scm_i_port_weak_hash);
  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
  return result;
}
#undef FUNC_NAME

void
scm_init_ioext ()
{
  scm_add_feature ("i/o-extensions");

#include "libguile/ioext.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_IOEXT_H
#define SCM_IOEXT_H

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 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_ftell (SCM object);
SCM_API SCM scm_redirect_port (SCM into_pt, SCM from_pt);
SCM_API SCM scm_dup_to_fdes (SCM fd_or_port, SCM newfd);
SCM_API SCM scm_dup2 (SCM oldfd, SCM newfd);
SCM_API SCM scm_fileno (SCM port);
SCM_API SCM scm_isatty_p (SCM port);
SCM_API SCM scm_fdopen (SCM fdes, SCM modes);
SCM_API SCM scm_primitive_move_to_fdes (SCM port, SCM fd);
SCM_API SCM scm_fdes_to_ports (SCM fd);
SCM_INTERNAL void scm_init_ioext (void);

#endif  /* SCM_IOEXT_H */

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

license: mit


code:
/* classes: h_files */

#ifndef SCM_ISELECT_H
#define SCM_ISELECT_H

/* Copyright (C) 1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 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"

/* Needed for FD_SET on some systems.  */
#include <sys/types.h>

#if SCM_HAVE_SYS_SELECT_H
# include <sys/select.h>
#endif

#if SCM_HAVE_WINSOCK2_H
# include <winsock2.h>
#endif

#ifdef FD_SET

#define SELECT_TYPE fd_set
#define SELECT_SET_SIZE FD_SETSIZE

#else /* no FD_SET */

/* Define the macros to access a single-int bitmap of descriptors.  */
#define SELECT_SET_SIZE 32
#define SELECT_TYPE int
#define FD_SET(n, p) (*(p) |= (1 << (n)))
#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
#define FD_ISSET(n, p) (*(p) & (1 << (n)))
#define FD_ZERO(p) (*(p) = 0)

#endif /* no FD_SET */

SCM_API int scm_std_select (int fds,
			    SELECT_TYPE *rfds,
			    SELECT_TYPE *wfds,
			    SELECT_TYPE *efds,
			    struct timeval *timeout);

#endif  /* SCM_ISELECT_H */

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


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 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 <string.h>

#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/hashtab.h"

#include "libguile/validate.h"
#include "libguile/keywords.h"
#include "libguile/strings.h"

static SCM keyword_obarray;

scm_t_bits scm_tc16_keyword;

#define KEYWORDP(X)	(SCM_SMOB_PREDICATE (scm_tc16_keyword, (X)))
#define KEYWORDSYM(X)	(SCM_SMOB_OBJECT (X))

static int
keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_puts ("#:", port);
  scm_display (KEYWORDSYM (exp), port);
  return 1;
}

SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if the argument @var{obj} is a keyword, else\n"
	    "@code{#f}.")
#define FUNC_NAME s_scm_keyword_p
{
  return scm_from_bool (KEYWORDP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0, 0,
	    (SCM symbol),
	    "Return the keyword with the same name as @var{symbol}.")
#define FUNC_NAME s_scm_symbol_to_keyword
{
  SCM keyword;

  SCM_ASSERT_TYPE (scm_is_symbol (symbol), symbol, 0, NULL, "symbol");

  SCM_CRITICAL_SECTION_START;
  /* njrev: NEWSMOB and hashq_set_x can raise errors */
  keyword = scm_hashq_ref (keyword_obarray, symbol, SCM_BOOL_F);
  if (scm_is_false (keyword))
    {
      SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol));
      scm_hashq_set_x (keyword_obarray, symbol, keyword);
    }
  SCM_CRITICAL_SECTION_END;
  return keyword;
}
#undef FUNC_NAME

SCM_DEFINE (scm_keyword_to_symbol, "keyword->symbol", 1, 0, 0,
	    (SCM keyword),
	    "Return the symbol with the same name as @var{keyword}.")
#define FUNC_NAME s_scm_keyword_to_symbol
{
  scm_assert_smob_type (scm_tc16_keyword, keyword);
  return KEYWORDSYM (keyword);
}
#undef FUNC_NAME

int
scm_is_keyword (SCM val)
{
  return KEYWORDP (val);
}

SCM
scm_from_locale_keyword (const char *str)
{
  return scm_symbol_to_keyword (scm_from_locale_symbol (str));
}

SCM
scm_from_locale_keywordn (const char *str, size_t len)
{
  return scm_symbol_to_keyword (scm_from_locale_symboln (str, len));
}

/* njrev: critical sections reviewed so far up to here */
void
scm_init_keywords ()
{
  scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
  scm_set_smob_print (scm_tc16_keyword, keyword_print);

  keyword_obarray = scm_c_make_hash_table (0);
#include "libguile/keywords.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_KEYWORDS_H
#define SCM_KEYWORDS_H

/* Copyright (C) 1995,1996,1999,2000,2001, 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_t_bits scm_tc16_keyword;

SCM_API SCM scm_keyword_p (SCM obj);
SCM_API SCM scm_symbol_to_keyword (SCM symbol);
SCM_API SCM scm_keyword_to_symbol (SCM keyword);

SCM_API int scm_is_keyword (SCM val);
SCM_API SCM scm_from_locale_keyword (const char *str);
SCM_API SCM scm_from_locale_keywordn (const char *str, size_t len);

SCM_INTERNAL void scm_init_keywords (void);

#endif  /* SCM_KEYWORDS_H */

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


code:
/* Convenience header for conditional use of GNU <libintl.h>.
   Copyright (C) 1995-1998, 2000-2002, 2006 Free Software Foundation, Inc.

   This program 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, or (at your option)
   any later version.

   This program 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 this program; if not, write to the Free Software
   Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
   USA.  */

#ifndef _LIBGETTEXT_H
#define _LIBGETTEXT_H 1

/* NLS can be disabled through the configure --disable-nls option.  */
#if ENABLE_NLS

/* Get declarations of GNU message catalog functions.  */
# include <libintl.h>

#else

/* Solaris /usr/include/locale.h includes /usr/include/libintl.h, which
   chokes if dcgettext is defined as a macro.  So include it now, to make
   later inclusions of <locale.h> a NOP.  We don't include <libintl.h>
   as well because people using "gettext.h" will not include <libintl.h>,
   and also including <libintl.h> would fail on SunOS 4, whereas <locale.h>
   is OK.  */
#if defined(__sun)
# include <locale.h>
#endif

/* Disabled NLS.
   The casts to 'const char *' serve the purpose of producing warnings
   for invalid uses of the value returned from these functions.
   On pre-ANSI systems without 'const', the config.h file is supposed to
   contain "#define const".  */
# define gettext(Msgid) ((const char *) (Msgid))
# define dgettext(Domainname, Msgid) ((const char *) (Msgid))
# define dcgettext(Domainname, Msgid, Category) ((const char *) (Msgid))
# define ngettext(Msgid1, Msgid2, N) \
    ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
# define dngettext(Domainname, Msgid1, Msgid2, N) \
    ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
# define dcngettext(Domainname, Msgid1, Msgid2, N, Category) \
    ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
# define textdomain(Domainname) ((const char *) (Domainname))
# define bindtextdomain(Domainname, Dirname) ((const char *) (Dirname))
# define bind_textdomain_codeset(Domainname, Codeset) ((const char *) (Codeset))

#endif

/* A pseudo function call that serves as a marker for the automated
   extraction of messages, but does not call gettext().  The run-time
   translation is done at a different place in the code.
   The argument, String, should be a literal string.  Concatenated strings
   and other string expressions won't work.
   The macro's expansion is not parenthesized, so that it is suitable as
   initializer for static 'char[]' or 'const char[]' variables.  */
#define gettext_noop(String) String

#endif /* _LIBGETTEXT_H */


code:
# Linker version script for libguile.           -*- ld-script -*-
#
# Copyright (C) 2009 Free Software Foundation, Inc.
#
# This file is part of GUILE.
#
# GUILE 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, or
# (at your option) any later version.
#
# GUILE 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 GUILE; see the file COPYING.LESSER.  If not,
# write to the Free Software Foundation, Inc., 51 Franklin Street,
# Fifth Floor, Boston, MA 02110-1301 USA

GUILE_2.0
{
  global:
    # Note: This includes `scm_i_' symbols declared as `SCM_API' (e.g.,
    # symbols from `deprecated.c' or symbols used by public inline
    # functions or macros).
    scm_*;

    # GDB interface.
    gdb_options;
    gdb_language;
    gdb_result;
    gdb_output;
    gdb_output_length;
    gdb_maybe_valid_type_p;
    gdb_read;
    gdb_eval;
    gdb_print;
    gdb_binding;

  local:
    *;
};


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

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

#include "libguile/_scm.h"
#include "libguile/eq.h"

#include "libguile/validate.h"
#include "libguile/list.h"
#include "libguile/eval.h"

#include <stdarg.h>

/* creating lists */

#define SCM_I_CONS(cell, x, y)			\
do {						\
  cell = scm_cell ((scm_t_bits)x, (scm_t_bits)y);			\
} while (0)

SCM
scm_list_1 (SCM e1)
{
  SCM c1;
  SCM_I_CONS (c1, e1, SCM_EOL);
  return c1;
}

SCM
scm_list_2 (SCM e1, SCM e2)
{
  SCM c1, c2;
  SCM_I_CONS (c2, e2, SCM_EOL);
  SCM_I_CONS (c1, e1, c2);
  return c1;
}

SCM
scm_list_3 (SCM e1, SCM e2, SCM e3)
{
  SCM c1, c2, c3;
  SCM_I_CONS (c3, e3, SCM_EOL);
  SCM_I_CONS (c2, e2, c3);
  SCM_I_CONS (c1, e1, c2);
  return c1;
}

SCM
scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4)
{
  return scm_cons2 (e1, e2, scm_list_2 (e3, e4));
}

SCM
scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5)
{
  return scm_cons2 (e1, e2, scm_list_3 (e3, e4, e5));
}

SCM
scm_list_n (SCM elt, ...)
{
  va_list foo;
  SCM answer = SCM_EOL;
  SCM *pos = &answer;

  va_start (foo, elt);
  while (! SCM_UNBNDP (elt))
    {
#if (SCM_DEBUG_CELL_ACCESSES == 1)
      if (SCM_NIMP (elt))
	SCM_VALIDATE_CELL(elt, 0);
#endif
      *pos = scm_cons (elt, SCM_EOL);
      pos = SCM_CDRLOC (*pos);
      elt = va_arg (foo, SCM);
    }
  va_end (foo);
  return answer;
}

SCM_DEFINE (scm_make_list, "make-list", 1, 1, 0,
            (SCM n, SCM init),
	    "Create a list containing of @var{n} elements, where each\n"
	    "element is initialized to @var{init}.  @var{init} defaults to\n"
	    "the empty list @code{()} if not given.")
#define FUNC_NAME s_scm_make_list
{
  unsigned nn = scm_to_uint (n);
  unsigned i;
  SCM ret = SCM_EOL;

  if (SCM_UNBNDP (init))
    init = SCM_EOL;

  for (i = 0; i < nn; i++)
    ret = scm_cons (init, ret);
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1,
            (SCM arg, SCM rest),
	    "Like @code{list}, but the last arg provides the tail of the\n"
	    "constructed list, returning @code{(cons @var{arg1} (cons\n"
	    "@var{arg2} (cons @dots{} @var{argn})))}.  Requires at least one\n"
	    "argument.  If given one argument, that argument is returned as\n"
	    "result.  This function is called @code{list*} in some other\n"
	    "Schemes and in Common LISP.")
#define FUNC_NAME s_scm_cons_star
{
  SCM ret = SCM_EOL;
  SCM *p = &ret;

  SCM_VALIDATE_REST_ARGUMENT (rest);

  for ( ; scm_is_pair (rest); rest = SCM_CDR (rest))
    {
      *p = scm_cons (arg, SCM_EOL);
      p = SCM_CDRLOC (*p);
      arg = SCM_CAR (rest);
    }

  *p = arg;
  return ret;
}
#undef FUNC_NAME

/* general questions about lists --- null?, list?, length, etc.  */

SCM_DEFINE (scm_null_p, "null?", 1, 0, 0,
           (SCM x),
	    "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.")
#define FUNC_NAME s_scm_null_p
{
  return scm_from_bool (SCM_NULL_OR_NIL_P (x));
}
#undef FUNC_NAME

SCM_DEFINE (scm_list_p, "list?", 1, 0, 0,
           (SCM x),
	    "Return @code{#t} iff @var{x} is a proper list, else @code{#f}.")
#define FUNC_NAME s_scm_list_p
{
  return scm_from_bool (scm_ilength (x) >= 0);
}
#undef FUNC_NAME

/* Return the length of SX, or -1 if it's not a proper list.
   This uses the "tortoise and hare" algorithm to detect "infinitely
   long" lists (i.e. lists with cycles in their cdrs), and returns -1
   if it does find one.  */
long
scm_ilength(SCM sx)
{
  long i = 0;
  SCM tortoise = sx;
  SCM hare = sx;

  do {
    if (SCM_NULL_OR_NIL_P(hare)) return i;
    if (!scm_is_pair (hare)) return -1;
    hare = SCM_CDR(hare);
    i++;
    if (SCM_NULL_OR_NIL_P(hare)) return i;
    if (!scm_is_pair (hare)) return -1;
    hare = SCM_CDR(hare);
    i++;
    /* For every two steps the hare takes, the tortoise takes one.  */
    tortoise = SCM_CDR(tortoise);
  }
  while (!scm_is_eq (hare, tortoise));

  /* If the tortoise ever catches the hare, then the list must contain
     a cycle.  */
  return -1;
}

SCM_DEFINE (scm_length, "length", 1, 0, 0,
           (SCM lst),
	    "Return the number of elements in list @var{lst}.")
#define FUNC_NAME s_scm_length
{
  long i;
  SCM_VALIDATE_LIST_COPYLEN (1, lst, i);
  return scm_from_long (i);
}
#undef FUNC_NAME

/* appending lists */

SCM_DEFINE (scm_append, "append", 0, 0, 1,
            (SCM args),
	    "Return a list consisting of the elements the lists passed as\n"
	    "arguments.\n"
	    "@lisp\n"
	    "(append '(x) '(y))          @result{}  (x y)\n"
	    "(append '(a) '(b c d))      @result{}  (a b c d)\n"
	    "(append '(a (b)) '((c)))    @result{}  (a (b) (c))\n"
	    "@end lisp\n"
	    "The resulting list is always newly allocated, except that it\n"
	    "shares structure with the last list argument.  The last\n"
	    "argument may actually be any object; an improper list results\n"
	    "if the last argument is not a proper list.\n"
	    "@lisp\n"
	    "(append '(a b) '(c . d))    @result{}  (a b c . d)\n"
	    "(append '() 'a)             @result{}  a\n"
	    "@end lisp")
#define FUNC_NAME s_scm_append
{
  SCM_VALIDATE_REST_ARGUMENT (args);
  if (scm_is_null (args)) {
    return SCM_EOL;
  } else {
    SCM res = SCM_EOL;
    SCM *lloc = &res;
    SCM arg = SCM_CAR (args);
    int argnum = 1;
    args = SCM_CDR (args);
    while (!scm_is_null (args)) {
      while (scm_is_pair (arg)) {
	*lloc = scm_cons (SCM_CAR (arg), SCM_EOL);
	lloc = SCM_CDRLOC (*lloc);
	arg = SCM_CDR (arg);
      }
      SCM_VALIDATE_NULL_OR_NIL (argnum, arg);
      arg = SCM_CAR (args);
      args = SCM_CDR (args);
      argnum++;
    };
    *lloc = arg;
    return res;
  }
}
#undef FUNC_NAME

SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
            (SCM lists),
	    "A destructive version of @code{append} (@pxref{Pairs and\n"
	    "Lists,,,r5rs, The Revised^5 Report on Scheme}).  The cdr field\n"
	    "of each list's final pair is changed to point to the head of\n"
	    "the next list, so no consing is performed.  Return\n"
	    "the mutated list.")
#define FUNC_NAME s_scm_append_x
{
  SCM ret, *loc;
  SCM_VALIDATE_REST_ARGUMENT (lists);

  if (scm_is_null (lists))
    return SCM_EOL;

  loc = &ret;
  for (;;)
    {
      SCM arg = SCM_CAR (lists);
      *loc = arg;

      lists = SCM_CDR (lists);
      if (scm_is_null (lists))
        return ret;

      if (!SCM_NULL_OR_NIL_P (arg))
        {
          SCM_VALIDATE_CONS (SCM_ARG1, arg);
          loc = SCM_CDRLOC (scm_last_pair (arg));
        }
    }
}
#undef FUNC_NAME

SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0,
           (SCM lst),
	    "Return the last pair in @var{lst}, signalling an error if\n"
	    "@var{lst} is circular.")
#define FUNC_NAME s_scm_last_pair
{
  SCM tortoise = lst;
  SCM hare = lst;

  if (SCM_NULL_OR_NIL_P (lst))
    return lst;

  SCM_VALIDATE_CONS (SCM_ARG1, lst);
  do {
    SCM ahead = SCM_CDR(hare);
    if (!scm_is_pair (ahead)) return hare;
    hare = ahead;
    ahead = SCM_CDR(hare);
    if (!scm_is_pair (ahead)) return hare;
    hare = ahead;
    tortoise = SCM_CDR(tortoise);
  }
  while (!scm_is_eq (hare, tortoise));
  SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
}
#undef FUNC_NAME

/* reversing lists */

SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0,
            (SCM lst),
	    "Return a new list that contains the elements of @var{lst} but\n"
	    "in reverse order.")
#define FUNC_NAME s_scm_reverse
{
  SCM result = SCM_EOL;
  SCM tortoise = lst;
  SCM hare = lst;

  do {
      if (SCM_NULL_OR_NIL_P(hare)) return result;
      SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
      result = scm_cons (SCM_CAR (hare), result);
      hare = SCM_CDR (hare);
      if (SCM_NULL_OR_NIL_P(hare)) return result;
      SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
      result = scm_cons (SCM_CAR (hare), result);
      hare = SCM_CDR (hare);
      tortoise = SCM_CDR (tortoise);
    }
  while (!scm_is_eq (hare, tortoise));
  SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
}
#undef FUNC_NAME

SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
            (SCM lst, SCM new_tail),
	    "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n"
	    "The Revised^5 Report on Scheme}).  The cdr of each cell in @var{lst} is\n"
	    "modified to point to the previous list element.  Return the\n"
	    "reversed list.\n\n"
	    "Caveat: because the list is modified in place, the tail of the original\n"
	    "list now becomes its head, and the head of the original list now becomes\n"
	    "the tail.  Therefore, the @var{lst} symbol to which the head of the\n"
	    "original list was bound now points to the tail.  To ensure that the head\n"
	    "of the modified list is not lost, it is wise to save the return value of\n"
	    "@code{reverse!}")
#define FUNC_NAME s_scm_reverse_x
{
  SCM_VALIDATE_LIST (1, lst);
  if (SCM_UNBNDP (new_tail))
    new_tail = SCM_EOL;
  else
    SCM_VALIDATE_LIST (2, new_tail);

  while (!SCM_NULL_OR_NIL_P (lst))
    {
      SCM old_tail = SCM_CDR (lst);
      SCM_SETCDR (lst, new_tail);
      new_tail = lst;
      lst = old_tail;
    }
  return new_tail;
}
#undef FUNC_NAME

/* indexing lists by element number */

SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0,
	    (SCM list, SCM k),
	    "Return the @var{k}th element from @var{list}.")
#define FUNC_NAME s_scm_list_ref
{
  SCM lst = list;
  unsigned long int i;
  i = scm_to_ulong (k);
  while (scm_is_pair (lst)) {
    if (i == 0)
      return SCM_CAR (lst);
    else {
      --i;
      lst = SCM_CDR (lst);
    }
  };
  if (SCM_NULL_OR_NIL_P (lst))
    SCM_OUT_OF_RANGE (2, k);
  else
    SCM_WRONG_TYPE_ARG (1, list);
}
#undef FUNC_NAME

SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0,
	    (SCM list, SCM k, SCM val),
	    "Set the @var{k}th element of @var{list} to @var{val}.")
#define FUNC_NAME s_scm_list_set_x
{
  SCM lst = list;
  unsigned long int i = scm_to_ulong (k);
  while (scm_is_pair (lst)) {
    if (i == 0) {
      SCM_SETCAR (lst, val);
      return val;
    } else {
      --i;
      lst = SCM_CDR (lst);
    }
  };
  if (SCM_NULL_OR_NIL_P (lst))
    SCM_OUT_OF_RANGE (2, k);
  else
    SCM_WRONG_TYPE_ARG (1, list);
}
#undef FUNC_NAME

SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);

SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0,
           (SCM lst, SCM k),
	    "@deffnx {Scheme Procedure} list-cdr-ref lst k\n"
	    "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
	    "The first element of the list is considered to be element 0.\n\n"
	    "@code{list-tail} and @code{list-cdr-ref} are identical.  It may help to\n"
	    "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
	    "or returning the results of cdring @var{k} times down @var{lst}.")
#define FUNC_NAME s_scm_list_tail
{
  size_t i = scm_to_size_t (k);
  while (i-- > 0) {
    SCM_VALIDATE_CONS (1, lst);
    lst = SCM_CDR(lst);
  }
  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
           (SCM list, SCM k, SCM val),
	    "Set the @var{k}th cdr of @var{list} to @var{val}.")
#define FUNC_NAME s_scm_list_cdr_set_x
{
  SCM lst = list;
  size_t i = scm_to_size_t (k);
  while (scm_is_pair (lst)) {
    if (i == 0) {
      SCM_SETCDR (lst, val);
      return val;
    } else {
      --i;
      lst = SCM_CDR (lst);
    }
  };
  if (SCM_NULL_OR_NIL_P (lst))
    SCM_OUT_OF_RANGE (2, k);
  else
    SCM_WRONG_TYPE_ARG (1, list);
}
#undef FUNC_NAME

/* copying lists, perhaps partially */

SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0,
           (SCM lst, SCM k),
	    "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
	    "return it.")
#define FUNC_NAME s_scm_list_head
{
  SCM answer;
  SCM * pos;
  size_t i = scm_to_size_t (k);

  answer = SCM_EOL;
  pos = &answer;
  while (i-- > 0)
    {
      SCM_VALIDATE_CONS (1, lst);
      *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
      pos = SCM_CDRLOC (*pos);
      lst = SCM_CDR(lst);
    }
  return answer;
}
#undef FUNC_NAME

/* Copy a list which is known to be finite.  The last pair may or may not have
 * a '() in its cdr.  That is, improper lists are accepted.  */
SCM
scm_i_finite_list_copy (SCM list)
{
  if (!scm_is_pair (list))
    {
      return list;
    }
  else
    {
      SCM tail;
      const SCM result = tail = scm_list_1 (SCM_CAR (list));
      list = SCM_CDR (list);
      while (scm_is_pair (list))
        {
          const SCM new_tail = scm_list_1 (SCM_CAR (list));
          SCM_SETCDR (tail, new_tail);
          tail = new_tail;
          list = SCM_CDR (list);
        }
      SCM_SETCDR (tail, list);

      return result;
    }
}

SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0,
            (SCM lst),
	    "Return a (newly-created) copy of @var{lst}.")
#define FUNC_NAME s_scm_list_copy
{
  SCM newlst;
  SCM * fill_here;
  SCM from_here;

  SCM_VALIDATE_LIST (1, lst);

  newlst = SCM_EOL;
  fill_here = &newlst;
  from_here = lst;

  while (scm_is_pair (from_here))
    {
      SCM c;
      c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
      *fill_here = c;
      fill_here = SCM_CDRLOC (c);
      from_here = SCM_CDR (from_here);
    }
  return newlst;
}
#undef FUNC_NAME

SCM_PROC (s_list, "list", 0, 0, 1, scm_list_copy);
SCM_SNARF_DOCS (primitive, scm_list_copy, "list", (SCM objs), 0, 0, 1,
                "Return a list containing @var{objs}, the arguments to\n"
                "@code{list}.")

/* This used to be the code for "list", but it's wrong when used via apply
   (it should copy the list).  It seems pretty unlikely anyone would have
   been using this from C code, since it's a no-op, but keep it for strict
   binary compatibility.  */
SCM
scm_list (SCM objs)
{
  return objs;
}

/* membership tests (memq, memv, etc.) */

/* The function scm_c_memq returns the first sublist of list whose car is
 * 'eq?' obj, where the sublists of list are the non-empty lists returned by
 * (list-tail list k) for k less than the length of list.  If obj does not
 * occur in list, then #f (not the empty list) is returned.
 * List must be a proper list, otherwise scm_c_memq may crash or loop
 * endlessly.
 */
SCM
scm_c_memq (SCM obj, SCM list)
{
  for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list))
    {
      if (scm_is_eq (SCM_CAR (list), obj))
	return list;
    }
  return SCM_BOOL_F;
}

SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
           (SCM x, SCM lst),
	    "Return the first sublist of @var{lst} whose car is @code{eq?}\n"
	    "to @var{x} where the sublists of @var{lst} are the non-empty\n"
	    "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
	    "@var{k} less than the length of @var{lst}.  If @var{x} does not\n"
	    "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
	    "returned.")
#define FUNC_NAME s_scm_memq
{
  SCM_VALIDATE_LIST (2, lst);
  return scm_c_memq (x, lst);
}
#undef FUNC_NAME

SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
           (SCM x, SCM lst),
	    "Return the first sublist of @var{lst} whose car is @code{eqv?}\n"
	    "to @var{x} where the sublists of @var{lst} are the non-empty\n"
	    "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
	    "@var{k} less than the length of @var{lst}.  If @var{x} does not\n"
	    "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
	    "returned.")
#define FUNC_NAME s_scm_memv
{
  SCM_VALIDATE_LIST (2, lst);
  for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
    {
      if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
	return lst;
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_member, "member", 2, 0, 0,
           (SCM x, SCM lst),
	    "Return the first sublist of @var{lst} whose car is\n"
	    "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
	    "the non-empty lists returned by @code{(list-tail @var{lst}\n"
	    "@var{k})} for @var{k} less than the length of @var{lst}.  If\n"
	    "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
	    "empty list) is returned.")
#define FUNC_NAME s_scm_member
{
  SCM_VALIDATE_LIST (2, lst);
  for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
    {
      if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
	return lst;
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

/* deleting elements from a list (delq, etc.) */

SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0,
           (SCM item, SCM lst),
	    "@deffnx {Scheme Procedure} delv! item lst\n"
	    "@deffnx {Scheme Procedure} delete! item lst\n"
	    "These procedures are destructive versions of @code{delq}, @code{delv}\n"
	    "and @code{delete}: they modify the existing @var{lst}\n"
	    "rather than creating a new list.  Caveat evaluator: Like other\n"
	    "destructive list functions, these functions cannot modify the binding of\n"
	    "@var{lst}, and so cannot be used to delete the first element of\n"
	    "@var{lst} destructively.")
#define FUNC_NAME s_scm_delq_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (scm_is_eq (SCM_CAR (walk), item))
	*prev = SCM_CDR (walk);
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0,
	    (SCM item, SCM lst),
	    "Destructively remove all elements from @var{lst} that are\n"
	    "@code{eqv?} to @var{item}.")
#define FUNC_NAME s_scm_delv_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
	*prev = SCM_CDR (walk);
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0,
	    (SCM item, SCM lst),
	    "Destructively remove all elements from @var{lst} that are\n"
	    "@code{equal?} to @var{item}.")
#define FUNC_NAME s_scm_delete_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
	*prev = SCM_CDR (walk);
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_delq, "delq", 2, 0, 0,
            (SCM item, SCM lst),
	    "Return a newly-created copy of @var{lst} with elements\n"
	    "@code{eq?} to @var{item} removed.  This procedure mirrors\n"
	    "@code{memq}: @code{delq} compares elements of @var{lst} against\n"
	    "@var{item} with @code{eq?}.")
#define FUNC_NAME s_scm_delq
{
  SCM copy = scm_list_copy (lst);
  return scm_delq_x (item, copy);
}
#undef FUNC_NAME

SCM_DEFINE (scm_delv, "delv", 2, 0, 0,
            (SCM item, SCM lst),
	    "Return a newly-created copy of @var{lst} with elements\n"
	    "@code{eqv?}  to @var{item} removed.  This procedure mirrors\n"
	    "@code{memv}: @code{delv} compares elements of @var{lst} against\n"
	    "@var{item} with @code{eqv?}.")
#define FUNC_NAME s_scm_delv
{
  SCM copy = scm_list_copy (lst);
  return scm_delv_x (item, copy);
}
#undef FUNC_NAME

SCM_DEFINE (scm_delete, "delete", 2, 0, 0,
            (SCM item, SCM lst),
	    "Return a newly-created copy of @var{lst} with elements\n"
	    "@code{equal?}  to @var{item} removed.  This procedure mirrors\n"
	    "@code{member}: @code{delete} compares elements of @var{lst}\n"
	    "against @var{item} with @code{equal?}.")
#define FUNC_NAME s_scm_delete
{
  SCM copy = scm_list_copy (lst);
  return scm_delete_x (item, copy);
}
#undef FUNC_NAME

SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0,
           (SCM item, SCM lst),
	    "Like @code{delq!}, but only deletes the first occurrence of\n"
	    "@var{item} from @var{lst}.  Tests for equality using\n"
	    "@code{eq?}.  See also @code{delv1!} and @code{delete1!}.")
#define FUNC_NAME s_scm_delq1_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (scm_is_eq (SCM_CAR (walk), item))
	{
	  *prev = SCM_CDR (walk);
	  break;
	}
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0,
            (SCM item, SCM lst),
	    "Like @code{delv!}, but only deletes the first occurrence of\n"
	    "@var{item} from @var{lst}.  Tests for equality using\n"
	    "@code{eqv?}.  See also @code{delq1!} and @code{delete1!}.")
#define FUNC_NAME s_scm_delv1_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
	{
	  *prev = SCM_CDR (walk);
	  break;
	}
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0,
            (SCM item, SCM lst),
	    "Like @code{delete!}, but only deletes the first occurrence of\n"
	    "@var{item} from @var{lst}.  Tests for equality using\n"
	    "@code{equal?}.  See also @code{delq1!} and @code{delv1!}.")
#define FUNC_NAME s_scm_delete1_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
	{
	  *prev = SCM_CDR (walk);
	  break;
	}
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_filter, "filter", 2, 0, 0,
	    (SCM pred, SCM list),
	    "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n"
	    "The list is not disordered -- elements that appear in the result list occur\n"
	    "in the same order as they occur in the argument list. The returned list may\n"
	    "share a common tail with the argument list. The dynamic order in which the\n"
	    "various applications of pred are made is not specified.\n\n"
	    "@lisp\n"
	    "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n"
	    "@end lisp")
#define FUNC_NAME s_scm_filter
{
  SCM walk;
  SCM *prev;
  SCM res = SCM_EOL;
  SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME);
  SCM_VALIDATE_LIST (2, list);

  for (prev = &res, walk = list;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk))))
	{
	  *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
	  prev = SCM_CDRLOC (*prev);
	}
    }

  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0,
	    (SCM pred, SCM list),
	    "Linear-update variant of @code{filter}.")
#define FUNC_NAME s_scm_filter_x
{
  SCM walk;
  SCM *prev;
  SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME);
  SCM_VALIDATE_LIST (2, list);

  for (prev = &list, walk = list;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk))))
	prev = SCM_CDRLOC (walk);
      else
	*prev = SCM_CDR (walk);
    }

  return list;
}
#undef FUNC_NAME

void
scm_init_list ()
{
#include "libguile/list.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_LIST_H
#define SCM_LIST_H

/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2005,2006,2008,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
 */

#include "libguile/__scm.h"

SCM_API SCM scm_list_1 (SCM e1);
SCM_API SCM scm_list_2 (SCM e1, SCM e2);
SCM_API SCM scm_list_3 (SCM e1, SCM e2, SCM e3);
SCM_API SCM scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4);
SCM_API SCM scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5);
SCM_API SCM scm_list_n (SCM elt, ...);
SCM_API SCM scm_list (SCM objs);
SCM_API SCM scm_list_head (SCM lst, SCM k);
SCM_API SCM scm_make_list (SCM n, SCM init);
SCM_API SCM scm_cons_star (SCM arg, SCM objs);
SCM_API SCM scm_null_p (SCM x);
SCM_API SCM scm_list_p (SCM x);
SCM_API long scm_ilength (SCM sx);
SCM_API SCM scm_length (SCM x);
SCM_API SCM scm_append (SCM args);
SCM_API SCM scm_append_x (SCM args);
SCM_API SCM scm_reverse (SCM lst);
SCM_API SCM scm_reverse_x (SCM lst, SCM newtail);
SCM_API SCM scm_list_ref (SCM lst, SCM k);
SCM_API SCM scm_list_set_x (SCM lst, SCM k, SCM val);
SCM_API SCM scm_list_cdr_set_x (SCM lst, SCM k, SCM val);
SCM_API SCM scm_last_pair (SCM sx);
SCM_API SCM scm_list_tail (SCM lst, SCM k);
SCM_API SCM scm_c_memq (SCM x, SCM lst);
SCM_API SCM scm_memq (SCM x, SCM lst);
SCM_API SCM scm_memv (SCM x, SCM lst);
SCM_API SCM scm_member (SCM x, SCM lst);
SCM_API SCM scm_delq_x (SCM item, SCM lst);
SCM_API SCM scm_delv_x (SCM item, SCM lst);
SCM_API SCM scm_delete_x (SCM item, SCM lst);
SCM_API SCM scm_list_copy (SCM lst);
SCM_API SCM scm_delq (SCM item, SCM lst);
SCM_API SCM scm_delv (SCM item, SCM lst);
SCM_API SCM scm_delete (SCM item, SCM lst);
SCM_API SCM scm_delq1_x (SCM item, SCM lst);
SCM_API SCM scm_delv1_x (SCM item, SCM lst);
SCM_API SCM scm_delete1_x (SCM item, SCM lst);
SCM_API SCM scm_filter (SCM pred, SCM list);
SCM_API SCM scm_filter_x (SCM pred, SCM list);
SCM_API SCM scm_copy_tree (SCM obj);

/* Guile internal functions */

SCM_INTERNAL SCM scm_i_finite_list_copy (SCM /* a list known to be finite */);
SCM_INTERNAL void scm_init_list (void);

#endif  /* SCM_LIST_H */

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


code:
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 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
 */

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

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

#include "libguile/_scm.h"
#include "libguile/private-gc.h" /* scm_getenv_int */
#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/chars.h"
#include "libguile/srfi-13.h"

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

#include "libguile/vm.h" /* for load-compiled/vm */

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

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

#ifdef HAVE_PWD_H
#include <pwd.h>
#endif /* HAVE_PWD_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;

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;
  char *encoding;
  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);

    encoding = scm_i_scan_for_encoding (port);
    if (encoding)
      scm_i_set_port_encoding_x (port, encoding);
    else
      /* The file has no encoding declared.  We'll presume Latin-1.  */
      scm_i_set_port_encoding_x (port, NULL);

    while (1)
      {
	SCM reader, form;

	/* Lookup and use the current reader to read the next
	   expression. */
	reader = scm_fluid_ref (the_reader);
	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 users should install Scheme code for use\n"
            "with this version of Guile.\n\n"
	    "E.g., may return \"/usr/share/guile/site/" SCM_EFFECTIVE_VERSION "\".")
#define FUNC_NAME s_scm_sys_site_dir
{
  return scm_from_locale_string (SCM_SITE_DIR);
}
#undef FUNC_NAME
#endif /* SCM_SITE_DIR */

#ifdef SCM_GLOBAL_SITE_DIR
SCM_DEFINE (scm_sys_global_site_dir, "%global-site-dir", 0,0,0,
            (),
	    "Return the directory where users should install Scheme code for use\n"
            "with all versions of Guile.\n\n"
	    "E.g., may return \"/usr/share/guile/site\".")
#define FUNC_NAME s_scm_sys_global_site_dir
{
  return scm_from_locale_string (SCM_GLOBAL_SITE_DIR);
}
#undef FUNC_NAME
#endif /* SCM_GLOBAL_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;

/* Like %load-path and %load-extensions, but for compiled files. */
static SCM *scm_loc_load_compiled_path;
static SCM *scm_loc_load_compiled_extensions;

/* Whether we should try to auto-compile. */
static SCM *scm_loc_load_should_autocompile;

/* The fallback path for autocompilation */
static SCM *scm_loc_compile_fallback_path;

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;
  SCM cpath = SCM_EOL;

#ifdef SCM_LIBRARY_DIR
  env = getenv ("GUILE_SYSTEM_PATH");
  if (env && strcmp (env, "") == 0)
    /* special-case interpret system-path=="" as meaning no system path instead
       of '("") */
    ;
  else if (env)
    path = scm_parse_path (scm_from_locale_string (env), path);
  else
    path = scm_list_4 (scm_from_locale_string (SCM_LIBRARY_DIR),
                       scm_from_locale_string (SCM_SITE_DIR),
                       scm_from_locale_string (SCM_GLOBAL_SITE_DIR),
                       scm_from_locale_string (SCM_PKGDATA_DIR));

  env = getenv ("GUILE_SYSTEM_COMPILED_PATH");
  if (env && strcmp (env, "") == 0)
    /* like above */
    ;
  else if (env)
    cpath = scm_parse_path (scm_from_locale_string (env), cpath);
  else
    cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath);

#endif /* SCM_LIBRARY_DIR */

  {
    char cachedir[1024];
    char *e;
#ifdef HAVE_GETPWENT
    struct passwd *pwd;
#endif

#define FALLBACK_DIR \
    "guile/ccache/" SCM_EFFECTIVE_VERSION "-" SCM_OBJCODE_MACHINE_VERSION_STRING

    if ((e = getenv ("XDG_CACHE_HOME")))
      snprintf (cachedir, sizeof(cachedir), "%s/" FALLBACK_DIR, e);
    else if ((e = getenv ("HOME")))
      snprintf (cachedir, sizeof(cachedir), "%s/.cache/" FALLBACK_DIR, e);
#ifdef HAVE_GETPWENT
    else if ((pwd = getpwuid (getuid ())) && pwd->pw_dir)
      snprintf (cachedir, sizeof(cachedir), "%s/.cache/" FALLBACK_DIR,
                pwd->pw_dir);
#endif /* HAVE_GETPWENT */
    else
      cachedir[0] = 0;

    if (cachedir[0])
      *scm_loc_compile_fallback_path = scm_from_locale_string (cachedir);
  }

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

  env = getenv ("GUILE_LOAD_COMPILED_PATH");
  if (env)
    cpath = scm_parse_path (scm_from_locale_string (env), cpath);

  *scm_loc_load_path = path;
  *scm_loc_load_compiled_path = cpath;
}

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

static int
scm_c_string_has_an_ext (char *str, size_t len, SCM extensions)
{
  for (; !scm_is_null (extensions); extensions = SCM_CDR (extensions))
    {
      char *ext;
      size_t extlen;
      int match;
      ext = scm_to_locale_string (SCM_CAR (extensions));
      extlen = strlen (ext);
      match = (len > extlen && str[len - extlen - 1] == '.'
               && strncmp (str + (len - extlen), ext, extlen) == 0);
      free (ext);
      if (match)
        return 1;
    }
  return 0;
}

/* 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, 0, 1,
            (SCM path, SCM filename, SCM rest),
	    "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 extensions, require_exts;
  SCM result = SCM_BOOL_F;

  if (SCM_UNBNDP (rest) || scm_is_null (rest))
    {
      /* Called either by Scheme code that didn't provide the optional
         arguments, or C code that used the Guile 1.8 signature (2 required,
         1 optional arg) and passed '() or nothing as the EXTENSIONS
	 argument.  */
      extensions = SCM_EOL;
      require_exts = SCM_UNDEFINED;
    }
  else
    {
      if (scm_is_null (SCM_CAR (rest)) || scm_is_pair (SCM_CAR (rest)))
	{
	  /* Called by Scheme code written for 1.9.  */
	  extensions = SCM_CAR (rest);
	  if (scm_is_null (SCM_CDR (rest)))
	    require_exts = SCM_UNDEFINED;
	  else
	    {
	      require_exts = SCM_CADR (rest);
	      if (SCM_UNLIKELY (!scm_is_null (SCM_CDDR (rest))))
		scm_wrong_num_args (scm_from_locale_string (FUNC_NAME));
	    }
	}
      else
	{
	  /* Called by C code that uses the 1.8 signature, i.e., which
	     expects the 3rd argument to be EXTENSIONS.  */
	  extensions = rest;
	  require_exts = SCM_UNDEFINED;
	}
    }

  if (SCM_UNBNDP (extensions))
    extensions = SCM_EOL;

  SCM_VALIDATE_LIST (3, extensions);

  if (SCM_UNBNDP (require_exts))
    require_exts = SCM_BOOL_F;

  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 res = filename;
      if (scm_is_true (require_exts) &&
          !scm_c_string_has_an_ext (filename_chars, filename_len,
                                    extensions))
        res = SCM_BOOL_F;

      scm_dynwind_end ();
      return res;
    }

  /* 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 == '.')
	  {
            if (scm_is_true (require_exts) &&
                !scm_c_string_has_an_ext (filename_chars, filename_len,
                                          extensions))
              {
                /* This filename has an extension, but not one of the right
                   ones... */
                scm_dynwind_end ();
                return SCM_BOOL_F;
              }
	    /* 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

static int
compiled_is_fresh (SCM full_filename, SCM compiled_filename)
{
  char *source, *compiled;
  struct stat stat_source, stat_compiled;
  int res;

  source = scm_to_locale_string (full_filename);
  compiled = scm_to_locale_string (compiled_filename);

  if (stat (source, &stat_source) == 0
      && stat (compiled, &stat_compiled) == 0
      && stat_source.st_mtime <= stat_compiled.st_mtime)
    {
      res = 1;
    }
  else
    {
      scm_puts (";;; note: source file ", scm_current_error_port ());
      scm_puts (source, scm_current_error_port ());
      scm_puts ("\n;;;       newer than compiled ", scm_current_error_port ());
      scm_puts (compiled, scm_current_error_port ());
      scm_puts ("\n", scm_current_error_port ());
      res = 0;
    }

  free (source);
  free (compiled);
  return res;
}

SCM_KEYWORD (kw_env, "env");

static SCM
do_try_autocompile (void *data)
{
  SCM source = PTR2SCM (data);
  SCM comp_mod, compile_file;

  scm_puts (";;; compiling ", scm_current_error_port ());
  scm_display (source, scm_current_error_port ());
  scm_newline (scm_current_error_port ());

  comp_mod = scm_c_resolve_module ("system base compile");
  compile_file = scm_module_variable
    (comp_mod, scm_from_locale_symbol ("compile-file"));

  if (scm_is_true (compile_file))
    {
      /* Auto-compile in the context of the current module.  */
      SCM res = scm_call_3 (scm_variable_ref (compile_file), source,
			    kw_env, scm_current_module ());
      scm_puts (";;; compiled ", scm_current_error_port ());
      scm_display (res, scm_current_error_port ());
      scm_newline (scm_current_error_port ());
      return res;
    }
  else
    {
      scm_puts (";;; it seems ", scm_current_error_port ());
      scm_display (source, scm_current_error_port ());
      scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n",
                scm_current_error_port ());
      return SCM_BOOL_F;
    }
}

static SCM
autocompile_catch_handler (void *data, SCM tag, SCM throw_args)
{
  SCM source = PTR2SCM (data);
  scm_puts (";;; WARNING: compilation of ", scm_current_error_port ());
  scm_display (source, scm_current_error_port ());
  scm_puts (" failed:\n", scm_current_error_port ());
  scm_puts (";;; key ", scm_current_error_port ());
  scm_write (tag, scm_current_error_port ());
  scm_puts (", throw args ", scm_current_error_port ());
  scm_write (throw_args, scm_current_error_port ());
  scm_newline (scm_current_error_port ());
  return SCM_BOOL_F;
}

SCM_DEFINE (scm_sys_warn_autocompilation_enabled, "%warn-autocompilation-enabled", 0, 0, 0,
	    (void), "")
#define FUNC_NAME s_scm_sys_warn_autocompilation_enabled
{
  static int message_shown = 0;

  if (!message_shown)
    {
      scm_puts (";;; note: autocompilation is enabled, set GUILE_AUTO_COMPILE=0\n"
                ";;;       or pass the --no-autocompile argument to disable.\n",
                scm_current_error_port ());
      message_shown = 1;
    }

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

static SCM
scm_try_autocompile (SCM source)
{
  if (scm_is_false (*scm_loc_load_should_autocompile))
    return SCM_BOOL_F;

  scm_sys_warn_autocompilation_enabled ();
  return scm_c_catch (SCM_BOOL_T,
                      do_try_autocompile,
                      SCM2PTR (source),
                      autocompile_catch_handler,
                      SCM2PTR (source),
                      NULL, NULL);
}

SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
	    (SCM args),
	    "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, unless the optional argument\n"
            "@var{exception_on_not_found} is @code{#f}, in which case\n"
            "@code{#f} is returned instead.")
#define FUNC_NAME s_scm_primitive_load_path
{
  SCM filename, exception_on_not_found;
  SCM full_filename, compiled_filename;
  int compiled_is_fallback = 0;

  if (scm_is_string (args))
    {
      /* C code written for 1.8 and earlier expects this function to take a
	 single argument (the file name).  */
      filename = args;
      exception_on_not_found = SCM_UNDEFINED;
    }
  else
    {
      /* Starting from 1.9, this function takes 1 required and 1 optional
	 argument.  */
      long len;

      SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, args, len);
      if (len < 1 || len > 2)
	scm_error_num_args_subr (FUNC_NAME);

      filename = SCM_CAR (args);
      SCM_VALIDATE_STRING (SCM_ARG1, filename);

      exception_on_not_found = len > 1 ? SCM_CADR (args) : SCM_UNDEFINED;
    }

  if (SCM_UNBNDP (exception_on_not_found))
    exception_on_not_found = SCM_BOOL_T;

  full_filename = scm_sys_search_load_path (filename);
  if (scm_is_string (full_filename))
    full_filename = scm_canonicalize_path (full_filename);

  compiled_filename =
    scm_search_path (*scm_loc_load_compiled_path,
		     filename,
		     scm_list_2 (*scm_loc_load_compiled_extensions,
				 SCM_BOOL_T));

  if (scm_is_false (compiled_filename)
      && scm_is_true (full_filename)
      && scm_is_true (*scm_loc_compile_fallback_path)
      && scm_is_pair (*scm_loc_load_compiled_extensions)
      && scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
    {
      SCM fallback = scm_string_append
        (scm_list_3 (*scm_loc_compile_fallback_path,
                     full_filename,
                     scm_car (*scm_loc_load_compiled_extensions)));
      if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
        {
          compiled_filename = fallback;
          compiled_is_fallback = 1;
        }
    }

  if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
    {
      if (scm_is_true (exception_on_not_found))
        SCM_MISC_ERROR ("Unable to find file ~S in load path",
                        scm_list_1 (filename));
      else
        return SCM_BOOL_F;
    }

  if (scm_is_false (full_filename)
      || (scm_is_true (compiled_filename)
          && compiled_is_fresh (full_filename, compiled_filename)))
    return scm_load_compiled_with_vm (compiled_filename);

  /* Perhaps there was the installed .go that was stale, but our fallback is
     fresh. Let's try that. Duplicating code, but perhaps that's OK. */

  if (!compiled_is_fallback
      && scm_is_true (*scm_loc_compile_fallback_path)
      && scm_is_pair (*scm_loc_load_compiled_extensions)
      && scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
    {
      SCM fallback = scm_string_append
        (scm_list_3 (*scm_loc_compile_fallback_path,
                     full_filename,
                     scm_car (*scm_loc_load_compiled_extensions)));
      if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))
          && compiled_is_fresh (full_filename, fallback))
        {
          scm_puts (";;; found fresh local cache at ", scm_current_error_port ());
          scm_display (fallback, scm_current_error_port ());
          scm_newline (scm_current_error_port ());
          return scm_load_compiled_with_vm (fallback);
        }
    }

  /* Otherwise, we bottom out here. */
  {
    SCM freshly_compiled = scm_try_autocompile (full_filename);

    if (scm_is_true (freshly_compiled))
      return scm_load_compiled_with_vm (freshly_compiled);
    else
      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));
}

void
scm_init_eval_in_scheme (void)
{
  SCM eval_scm, eval_go;
  eval_scm = scm_search_path (*scm_loc_load_path,
                              scm_from_locale_string ("ice-9/eval.scm"),
                              SCM_EOL);
  eval_go = scm_search_path (*scm_loc_load_compiled_path,
                             scm_from_locale_string ("ice-9/eval.go"),
                             SCM_EOL);

  if (scm_is_true (eval_scm) && scm_is_true (eval_go)
      && compiled_is_fresh (eval_scm, eval_go))
    scm_load_compiled_with_vm (eval_go);
  else
    /* if we have no eval.go, we shouldn't load any compiled code at all */
    *scm_loc_load_compiled_path = SCM_EOL;
}

/* Information about the build environment.  */

SCM_VARIABLE_INIT (sys_host_type, "%host-type",
		   scm_from_locale_string (HOST_TYPE));

/* 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_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_compiled_path
    = SCM_VARIABLE_LOC (scm_c_define ("%load-compiled-path", SCM_EOL));
  scm_loc_load_compiled_extensions
    = SCM_VARIABLE_LOC (scm_c_define ("%load-compiled-extensions",
				      scm_list_1 (scm_from_locale_string (".go"))));
  scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F));

  scm_loc_compile_fallback_path
    = SCM_VARIABLE_LOC (scm_c_define ("%compile-fallback-path", SCM_BOOL_F));
  scm_loc_load_should_autocompile
    = SCM_VARIABLE_LOC (scm_c_define ("%load-should-autocompile", SCM_BOOL_F));

  the_reader = scm_make_fluid ();
  scm_fluid_set_x (the_reader, SCM_BOOL_F);
  scm_c_define("current-reader", the_reader);

  scm_c_define ("load-compiled",
                scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
                                  scm_load_compiled_with_vm));

  init_build_info ();

#include "libguile/load.x"
}

void
scm_init_load_should_autocompile ()
{
  *scm_loc_load_should_autocompile =
    scm_from_bool (scm_getenv_int ("GUILE_AUTO_COMPILE", 1));
}

/*
  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, 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
 */

#include "libguile/__scm.h"

SCM_API SCM scm_parse_path (SCM path, SCM tail);
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_sys_global_site_dir (void);
SCM_API SCM scm_search_path (SCM path, SCM filename, SCM rest);
SCM_API SCM scm_sys_search_load_path (SCM filename);
SCM_API SCM scm_primitive_load_path (SCM filename_and_exception_on_not_found);
SCM_API SCM scm_c_primitive_load_path (const char *filename);
SCM_INTERNAL SCM scm_sys_warn_autocompilation_enabled (void);
SCM_INTERNAL void scm_init_load_path (void);
SCM_INTERNAL void scm_init_load (void);
SCM_INTERNAL void scm_init_load_should_autocompile (void);
SCM_INTERNAL void scm_init_eval_in_scheme (void);

#endif  /* SCM_LOAD_H */

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


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

/* A list of all available locale categories, not including `ALL'.  */

/* The six standard categories, as defined in IEEE Std 1003.1-2001.  */
SCM_DEFINE_LOCALE_CATEGORY (COLLATE)
SCM_DEFINE_LOCALE_CATEGORY (CTYPE)

#ifdef LC_MESSAGES
/* MinGW doesn't have `LC_MESSAGES'.  */
SCM_DEFINE_LOCALE_CATEGORY (MESSAGES)
#endif

SCM_DEFINE_LOCALE_CATEGORY (MONETARY)
SCM_DEFINE_LOCALE_CATEGORY (NUMERIC)
SCM_DEFINE_LOCALE_CATEGORY (TIME)

/* Additional non-standard categories.  */
#ifdef LC_PAPER
SCM_DEFINE_LOCALE_CATEGORY (PAPER)
#endif
#ifdef LC_NAME
SCM_DEFINE_LOCALE_CATEGORY (NAME)
#endif
#ifdef LC_ADDRESS
SCM_DEFINE_LOCALE_CATEGORY (ADDRESS)
#endif
#ifdef LC_TELEPHONE
SCM_DEFINE_LOCALE_CATEGORY (TELEPHONE)
#endif
#ifdef LC_MEASUREMENT
SCM_DEFINE_LOCALE_CATEGORY (MEASUREMENT)
#endif
#ifdef LC_IDENTIFICATION
SCM_DEFINE_LOCALE_CATEGORY (IDENTIFICATION)
#endif


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

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

#include "libguile/_scm.h"
#include "libguile/ports.h"
#include "libguile/print.h"
#include "libguile/smob.h"
#include "libguile/validate.h"
#include "libguile/macros.h"

#include "libguile/private-options.h"

static scm_t_bits scm_tc16_macro;

#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
#define SCM_MACRO_PRIMITIVE(m) ((scm_t_macro_primitive)SCM_SMOB_DATA (m))
#define SCM_MACRO_NAME(m) (SCM_SMOB_OBJECT_2 (m))
#define SCM_MACRO_TYPE(m) (SCM_SMOB_OBJECT_3 (m))
#define SCM_MACRO_BINDING(m) (SCM_CELL_OBJECT ((m), 4))
#define SCM_VALIDATE_MACRO(p,v) SCM_MAKE_VALIDATE ((p), (v), MACROP)

SCM_API scm_t_bits scm_tc16_macro;

static int
macro_print (SCM macro, SCM port, scm_print_state *pstate)
{
  if (scm_is_false (SCM_MACRO_TYPE (macro)))
    scm_puts ("#<primitive-syntax-transformer ", port);
  else
    scm_puts ("#<syntax-transformer ", port);
  scm_iprin1 (scm_macro_name (macro), port, pstate);
  scm_putc ('>', port);

  return 1;
}

/* Return a mmacro that is known to be one of guile's built in macros. */
SCM
scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn)
{
  SCM z = scm_words (scm_tc16_macro, 5);
  SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn);
  SCM_SET_SMOB_DATA_N (z, 2, scm_from_locale_symbol (name));
  SCM_SET_SMOB_DATA_N (z, 3, SCM_BOOL_F);
  SCM_SET_SMOB_DATA_N (z, 4, SCM_BOOL_F);
  return z;
}

scm_t_macro_primitive
scm_i_macro_primitive (SCM macro)
{
  return SCM_MACRO_PRIMITIVE (macro);
}

SCM_DEFINE (scm_make_syntax_transformer, "make-syntax-transformer", 3, 0, 0,
            (SCM name, SCM type, SCM binding),
	    "Construct a @dfn{syntax transformer}.\n\n"
            "This function is part of Guile's low-level support for the psyntax\n"
            "syntax expander. Users should not call this function.")
#define FUNC_NAME s_scm_make_syntax_transformer
{
  SCM z;
  SCM (*prim)(SCM,SCM) = NULL;

  if (scm_is_true (name))
    {
      SCM existing_var;

      SCM_VALIDATE_SYMBOL (1, name);
      existing_var = scm_sym2var (name, scm_current_module_lookup_closure (),
                                  SCM_BOOL_F);
      if (scm_is_true (existing_var)
          && scm_is_true (scm_variable_bound_p (existing_var))
          && SCM_MACROP (SCM_VARIABLE_REF (existing_var)))
        prim = SCM_MACRO_PRIMITIVE (SCM_VARIABLE_REF (existing_var));
    }

  SCM_VALIDATE_SYMBOL (2, type);

  z = scm_words (scm_tc16_macro, 5);
  SCM_SET_SMOB_DATA_N (z, 1, prim);
  SCM_SET_SMOB_DATA_N (z, 2, name);
  SCM_SET_SMOB_DATA_N (z, 3, type);
  SCM_SET_SMOB_DATA_N (z, 4, binding);
  return z;
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a syntax transformer (an object that "
            "transforms Scheme expressions at expansion-time).\n\n"
            "Macros are actually just one kind of syntax transformer; this\n"
            "procedure has its name due to historical reasons.")
#define FUNC_NAME s_scm_macro_p
{
  return scm_from_bool (SCM_MACROP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
            (SCM m),
	    "Return the type of the syntax transformer @var{m}, as passed to\n"
            "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n"
            "transformer, @code{#f} will be returned.")
#define FUNC_NAME s_scm_macro_type
{
  SCM_VALIDATE_MACRO (1, m);
  return SCM_MACRO_TYPE (m);
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
            (SCM m),
	    "Return the name of the syntax transformer @var{m}.")
#define FUNC_NAME s_scm_macro_name
{
  SCM_VALIDATE_MACRO (1, m);
  return SCM_MACRO_NAME (m);
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
            (SCM m),
	    "Return the transformer procedure of the macro @var{m}.\n\n"
            "If @var{m} is a syntax transformer but not a macro, @code{#f}\n"
            "will be returned. (This can happen, for example, with primitive\n"
            "syntax transformers).")
#define FUNC_NAME s_scm_macro_transformer
{
  SCM_VALIDATE_MACRO (1, m);
  /* here we rely on knowledge of how psyntax represents macro bindings, but
     hey, there is code out there that calls this function, and expects to get
     a procedure in return... */
  if (scm_is_true (scm_procedure_p (SCM_MACRO_BINDING (m))))
    return SCM_MACRO_BINDING (m);
  else
    return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0,
            (SCM m),
	    "Return the binding of the syntax transformer @var{m}, as passed to\n"
            "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n"
            "transformer, @code{#f} will be returned.")
#define FUNC_NAME s_scm_macro_binding
{
  SCM_VALIDATE_MACRO (1, m);
  return SCM_MACRO_BINDING (m);
}
#undef FUNC_NAME

void
scm_init_macros ()
{
  scm_tc16_macro = scm_make_smob_type ("macro", 0);
  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, 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
 */

#include "libguile/__scm.h"

typedef SCM (*scm_t_macro_primitive) (SCM, SCM);

SCM_API SCM scm_make_syntax_transformer (SCM name_or_existing_definition,
                                         SCM type, SCM binding);
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_binding (SCM m);
SCM_API SCM scm_macro_transformer (SCM m);

SCM_INTERNAL SCM scm_i_make_primitive_macro (const char *name,
                                             scm_t_macro_primitive fn);
SCM_INTERNAL scm_t_macro_primitive scm_i_macro_primitive (SCM m);

SCM_INTERNAL void scm_init_macros (void);

#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 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 "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 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_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, 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_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_INTERNAL void scm_init_mallocs (void);

#endif  /* SCM_MALLOCS_H */

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


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